VBA使用頻度の高いコード（１）：５行以上の結合セルに合わせて写真貼付け

５行以上の結合セルに合わせて写真貼付け

結合セルに合わせて写真サイズ修正貼付け用のコードです

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub 写真貼付直接()
'===============セル選択＆セル選択エラー判定付(6行以上の結合セルのみ貼り付け)
Dim i As Long, MargeCHK, Celldata As String
Dim PicWidth, PicHeight
Dim Pict As String
Dim CurrentPath1 As String
Dim H_CHK, W_CHK As Double
Dim RotateDirection As Single
ActiveSheet.Unprotect

If TypeName(Selection) = "Range" Then
If Selection.MergeCells Then
If Selection.Rows.Count > 5 Then
'buf = "写真貼付します" & vbCrLf
Else
Exit Sub
End If
Else
Exit Sub
End If
Else
MsgBox "セルを選択してから実行してください。"
Exit Sub
End If

Celldata = Selection.Address

'===============画像選択

ChDir ActiveWorkbook.Path
myF = Application.GetOpenFilename _
("jpg bmp tif png,*.jpg;*.bmp;*.tif;*.png", , "画像の選択", , False)
If myF = False Then
MsgBox "画像を選択してください(終了)"
Exit Sub
End If

'===============画像表示サイズを75％へ
ActiveWindow.Zoom = 75

'===============セルサイズを計算

PicWidth = Selection.Width
PicHeight = Selection.Height

'===============画像の貼り付け

With ActiveSheet.Pictures.Insert(Filename:=myF)
.CopyPicture 'クリップボードにコピー
.Delete '画像をいったん削除
End With
ActiveSheet.Paste '画像を貼り付け
Selection.Name = "Pic" & Format(Now, "yyyymmddhhnnss")
Pict = Selection.Name

'===============セルサイズに合わせて変更+回転方向判定:90度回転の場合横に引き延ばす
RotateDirection = ActiveSheet.Shapes(Pict).Rotation

If RotateDirection = 0 Or RotateDirection = 180 Then
W_CHK = PicWidth
H_CHK = PicHeight
Else
W_CHK = PicHeight
H_CHK = PicWidth
End If

With ActiveSheet.Shapes(Pict)
.LockAspectRatio = msoFalse
.Placement = xlFreeFloating
.Placement = xlMove
.Top = Range(Celldata).Top
.Left = Range(Celldata).Left
.Width = W_CHK
.Height = H_CHK
End With

End Sub

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝