Excelの画像一括挿入マクロを改良したい
以下の質問の回答者さんの頂戴し少し改変して、マクロでExcelの画像を一括挿入しています。
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q12139845762
貼り付けるセルが一列に並び画像を連続して下に貼り付けるだけであればこちらのマクロで大丈夫なのですが、
貼り付けるセルが2列3行になり、
1番目の写真 2番目の写真
3番目の写真 4番目の写真
5番目の写真 6番目の写真
という風に貼り付けたいときにどうしたらよいのかがわかりません。
ActiveCell.Offset(21).Select
の所で、セルの行が21下がって貼り付けられるということはわかるのですが…
使っているExcelファイルはいわゆるセルが方眼紙のようになっており、15行19列のセルを結合してそこに写真を貼り付けています。
1番目の写真を貼り付けた後に2列移動して貼り付けたいです。
ご教授いただければ幸いです。
使用しているマクロ↓
Sub ShpAdTest()
Dim FNames As Variant, myShp As Shape
Dim Fn As String, i As Long
FNames = Application.GetOpenFilename( _
filefilter:="Image(*.jpg;*.gif;*.bmp;*.png),*.jpg;*.gif;*.bmp;*.png", _
Title:="図の挿入(複数選択可）", _
MultiSelect:=True)
If Not IsArray(FNames) Then Exit Sub
Call BubbleSort_Str(FNames, True, vbTextCompare)
Application.ScreenUpdating = False
For i = LBound(FNames) To UBound(FNames)
PasteShp (FNames(i))
With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
.LockAspectRatio = msoTrue
.Placement = xlMove
.DrawingObject.PrintObject = True
.Height = ActiveCell.MergeArea.Height
If .Width > ActiveCell.MergeArea.Width Then
.Width = ActiveCell.MergeArea.Width
End If
.Top = ActiveCell.MergeArea.Top + (ActiveCell.MergeArea.Height - .Height) / 2
.Left = ActiveCell.MergeArea.Left + (ActiveCell.MergeArea.Width - .Width) / 2
End With
ActiveCell.Offset(21).Select
Next
Call ShpCutPaste
Application.ScreenUpdating = True
End Sub
Sub PasteShp(fname As Variant)
Dim Shp As Shape
Set Shp = ActiveSheet.Shapes.AddPicture( _
filename:=fname, _
linktofile:=False, savewithdocument:=True, _
Left:=Selection.Left, Top:=Selection.Top, _
Width:=0, Height:=0)
Shp.ScaleHeight 1!, msoTrue
Shp.ScaleWidth 1!, msoTrue
Set Shp = Nothing
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
' ↓ 画像のリンク解除と画像ファイルサイズの低減
Private Sub ShpCutPaste()
Dim Shp As Shape, Nm As String
Dim x As Double, y As Double
Application.ScreenUpdating = False
For Each Shp In ActiveSheet.Shapes
With Shp
x = .Left
y = .Top
Nm = .Name
.Cut
End With
ActiveSheet.PasteSpecial Format:="図 (JPEG)", _
Link:=False, DisplayAsIcon:=False
With Selection
.Left = x
.Top = y
.Name = Nm
End With
Application.CutCopyMode = False
Next
Application.ScreenUpdating = True
End Sub
お礼
ありがとうございます。 おかげさまで木を描けました。