[[20171129083916]]　『エクセルに、セルを結合せずに写真を貼り付け』（kao）　ページの最後に飛ぶ

『エクセルに、セルを結合せずに写真を貼り付け』（kao）

エクセルに、セルを結合して写真を一気に複数貼ると言うマクロは
あるのですが今回やりたいことは下記です。

 １、セルは、結合しない。
 ２、画像を、複数枚挿入してからその画像を同じサイズにしたい。
 ３、２×３か３×３で、並べる。たまに、横に５～６枚の時もある。
 ４、セルの幅は、「１．８８」で統一してA3横で作成。
　　 そこに、何段×何列かを、使用して写真サイズを変更し最終的に
　　 サイズプロパティか何かでサイズを統一させる。
 ５、貼った瞬間貼り付け元からのリンクは解除するようにして写真の場所が
　　 変更されてもエクセルへ貼り付けた画像が表示されなくならないように
　　 したい。

 こんなことが。実現できる機能が欲しいのですがマクロか何かでできないで 
 しょうか？

＜使用 Excel：Excel2013、使用 OS：Windows10 ＞

セルのサイズと画像のサイズは別物であり、セルに合わせているように画像の位置とサイズを調整しているだけですよ。だから、画像サイズを指定している箇所を手直しするだけのはず。まずは今のマクロを見せてもらわないと、直しようがありませんが。

例えば、幅を Range("A1").Width に合わせているものを、Range("A1:D5").Width に合わせるだけ…、というヒントで、ご自分で直せませんかね？
（???） 2017/11/29(水) 08:55

あと、リンク貼りつけにすると元画像の変化に引きずられますが、実体を貼りつけると、画像ファイルがブック内にそのまま取り込まれるので、元画像とは無関係になります。この辺も、いまどういうコードになっているのか次第ですが、画像貼りつけについて検索すれば、コード例は沢山見つかると思いますよ。
（???） 2017/11/29(水) 09:01

Sub 複数の画像を挿入()

    Dim strFilter As String
    Dim Filenames As Variant
    Dim PIC       As Picture
    Dim i

     ' 「ファイルを開く」ダイアログでファイル名を取得
     strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
    Filenames = Application.GetOpenFilename( _
                    FileFilter:=strFilter, _
                    Title:="図の挿入(複数選択可）", _
                    MultiSelect:=True)
    If Not IsArray(Filenames) Then Exit Sub

     ' ファイル名をソート
    Call BubbleSort_Str(Filenames, True, vbTextCompare)

     ' 貼り付け開始セルを選択
     Range("CF5").Select

     ' マクロ実行中の画面描写を停止
     Application.ScreenUpdating = False
    ' 順番に画像を挿入
     For i = LBound(Filenames) To UBound(Filenames)
        Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))

         '-------------------------------------------------------------
        ' 画像の各種プロパティ変更
         '-------------------------------------------------------------
        With PIC
            .Top = ActiveCell.Top        ' 位置：アクティブセルの上側に重ねる
            .Left = ActiveCell.Left      ' 位置：アクティブセルの左側に重ねる
            .Placement = xlMove          ' 移動するがサイズ変更しない
            .PrintObject = True          ' 印刷する
        End With
        With PIC.ShapeRange
            .LockAspectRatio = msoTrue   ' 縦横比維持
             ' 画像の高さをアクティブセルにあわせる
            ' 結合セルの場合でも対応
             .Height = ActiveCell.MergeArea.Height
        End With

        ' 次の貼り付け先を選択（アクティブセルにする）[例：12個下のセル]
        ActiveCell.Offset(12).Select

         Set PIC = Nothing
    Next i

     ' 終了
     Application.ScreenUpdating = True
    MsgBox i & "枚の画像を挿入しました", vbInformation

 End Sub

' バブルソート（文字列）
Private Sub BubbleSort_Str( _

 ByRef Source As Variant, _
 Optional ByVal SortAsc As Boolean = True, _
 Optional ByVal Compare As VbCompareMethod = vbTextCompare)

 If Not IsArray(Source) Then Exit Sub

 Dim i As Long, j As Long
 Dim vntTmp As Variant
 For i = LBound(Source) To UBound(Source) - 1
 For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1
 If StrComp(Source(IIf(SortAsc, j, j + 1)), _
 Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then
 vntTmp = Source(j)
 Source(j) = Source(j + 1)
 Source(j + 1) = vntTmp
 End If
 Next j
 Next i

 End Sub

 これが、使えそうってことが分かったのですがセルの場所を任意にしたい場合はどうすればよいですか？

 Range("CF5").Select

 また、高さ調整：１２％、幅調整：１３％を、初めっから指定する場合どうすればよいですか？
（kao） 2017/11/29(水) 09:19

＞　エクセルに、セルを結合して写真を一気に複数貼ると言うマクロはあるのですが
んと、写真をシート上に挿入することと、
セルを結合することは関係ありません。
手動の時の流れで、罫線を引くのにセルが結合してあった方が、
線を引きやすいという程度の理由でそういうことがされているのではないかと想像します。（方眼紙みたいにシートを使って任意にセルを
結合して利用することはよくされてますよねー）

どのセルの左上にどの写真の左上を合わせるか、（あるいは少しずらすとか）
それをVBA語で指示してやるだけです。
今あるコードの内、セルの接合を指示している文言を削除し、
どのセルに左上を合わせるかを指示する文言を書けば、よいと思います。

http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_800_400.html
http://excel-ubara.com/excelvba5/EXCELVBA232.html
http://language-and-engineering.hatenablog.jp/entry/20131109/GenerateImageThumbnailAlbumByExcelVBA

（まっつわん） 2017/11/29(水) 09:22

　＞これが、使えそうってことが分かったのですがセルの場所を任意にしたい場合はどうすればよいですか？
　＞ Range("CF5").Select

要らなければ削除すればよいです。

　＞また、高さ調整：１２％、幅調整：１３％を、初めっから指定する場合どうすればよいですか？
マクロの記録という機能を使って手動の操作をコード化してみたら、コードが判ると思います。

（まっつわん） 2017/11/29(水) 09:28

コード動かしてみましたが、貼った画像数とMsgBoxに表示する数が合ってないし…。元のコードの高度さを考えると、こんなミスをするはずはないのですけどねぇ。誰かに丸々作ってもらったコードっぽい感じですね。

私だったらこう変えるなぁ、という例なぞ。 ActiveCellを元にするというのは好きではないのですが、元の考え方を踏襲しています。
ご指定のセルサイズから、A3横サイズいっぱいに並べるには89*71セル、と逆算し、セル数から画像サイズを決めてみました。
画像の縦横比は固定にする方が好みですが、縦横比を変えて全画像同じサイズに合わせています。（そのあたりはご自分で調べて直してください）

 Sub test()
    Dim Filenames As Variant
    Dim i As Long
    Dim iWidth As Single
    Dim iHeight As Single

    ActiveSheet.Range("A1").Select

    With ActiveCell.Resize(23, 29)
        iWidth = .Width
        iHeight = .Height
    End With

    Filenames = Application.GetOpenFilename( _
        FileFilter:="画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png", _
        Title:="図の挿入(複数選択可）", MultiSelect:=True)
    If Not IsArray(Filenames) Then Exit Sub

    Application.ScreenUpdating = False

    With CreateObject("System.Collections.ArrayList")
        For i = LBound(Filenames) To UBound(Filenames)
            .Add Filenames(i)
        Next i
        .Sort

        For i = 0 To .Count - 1
            With ActiveSheet.Shapes.AddPicture(.Item(i), msoFalse, msoTrue, _
                ActiveCell.Offset(0, (i Mod 3) * 30).Left, _
                ActiveCell.Offset(Int(i / 3) * 24, 0).Top, _
                iWidth, _
                iHeight)
            End With
        Next i

        Application.ScreenUpdating = True
        MsgBox .Count & "枚の画像を挿入しました", vbInformation
    End With
 End Sub
（???） 2017/11/29(水) 11:17

コメント返信：

[ 一覧(最新更新順) ]

[[20171129083916]] 『エクセルに、セルを結合せずに写真を貼り付け』（kao） ページの最後に飛ぶ

[[20171129083916]]　『エクセルに、セルを結合せずに写真を貼り付け』（kao）　ページの最後に飛ぶ