エクセルでのマクロ - Visual Basic - 教えて！goo

こんにちは。KenKen_SP です。

> エクセルでのマクロ
> 素朴な質問なんですが…

マクロとわかっているなら、質問としては既に解決済みなのではないかと...

> このときコントロールキーとQを押すだけで...

マクロを Ctrl＋Q のショートカットを割り当てているのですね。

過去に何回か作ったことがある内容なのでアップしますが、マクロの貼り付け方
はご自分でお調べ下さい。 WEB や書籍ですぐわかりますから。
貼り付ける場所は「標準モジュール」です。

1～複数枚の画像を一度に処理します。

’以下ソースコード

Option Explicit

Sub 複数の画像を挿入() ' 1枚でも OK
　
　　Dim vFNames　As Variant
　　Dim vFName　 As Variant
　　Dim Pic　　　As Picture
　　Dim sOffset　As String
　　
　　ActiveCell.Select
　　' ファイル名問い合わせ
　　vFNames = Application.GetOpenFilename( _
　　　　　　　FileFilter:="Image(*.jpg;*.gif;*.bmp;*.png),*.jpg;*.gif;*.bmp;*.png", _
　　　　　　　Title:="図の挿入(複数選択可）", _
　　　　　　　MultiSelect:=True)
　　If Not IsArray(vFNames) Then Exit Sub
　　' 2枚以上なら貼り付け間隔問い合わせ
　　If UBound(vFNames) > 1 Then
　　　　Do
　　　　　　sOffset = InputBox("1～20の整数を入力します", _
　　　　　　　　　　　　　　　 "貼り付け間隔の指定", Default:=2)
　　　　　　If sOffset = "" Then
　　　　　　　　Exit Sub
　　　　　　ElseIf Val(sOffset) >= 1 And Val(sOffset) <= 20 Then
　　　　　　　　Exit Do
　　　　　　End If
　　　　Loop
　　Else
　　　　sOffset = "0"
　　End If
　　' ファイル名をソート
　　Call ComSort(vFNames, True, True, vbTextCompare)
　　' マクロ実行中の画面描写を停止し、画像挿入開始
　　Application.ScreenUpdating = False
　　For Each vFName In vFNames
　　　　' 順番に画像を挿入
　　　　Set Pic = ActiveSheet.Pictures.Insert(vFName)
　　　　' 一つ右側のセルにファイル名を挿入
　　　　ActiveCell.Offset(0, 1).Value = Dir$(vFName)
　　　　' 画像プロパティ変更-----------------------------------------
　　　　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
　　　　'-----------------------------------------------------------
　　　　' 次の貼り付け先のセルをアクティブにする
　　　　ActiveCell.Offset(sOffset).Activate
　　Next
　　' 終了
　　Set Pic = Nothing
　　Application.ScreenUpdating = True
　　If UBound(vFNames) > 1 Then
　　　　MsgBox CStr(UBound(vFNames)) & "枚の画像を挿入しました", _
　　　　　　　 vbInformation, "正常終了したみたい(・∀・)"
　　End If
　　Erase vFNames
End Sub

' // コムソート（ファイル名の入った配列をソートするのに使います）
Public Sub ComSort( _
　　ByRef Src As Variant, _
　　Optional ByVal CompStr As Boolean = False, _
　　Optional ByVal SortAsc As Boolean = True, _
　　Optional ByVal Compare As VbCompareMethod = vbTextCompare)
　　
　　Dim lLow As Long, lUpr As Long, lGap As Long, i As Long
　　Dim vTmp As Variant
　　Dim bSwt As Boolean, bFlg As Boolean
　　
　　lLow = LBound(Src): lUpr = UBound(Src)
　　lGap = lUpr - lLow
　　bSwt = True
　　
　　Do While lGap > 1 Or bSwt
　　　　lGap = Int(lGap / 1.3)
　　　　Select Case lGap
　　　　　　Case Is = 9, 10: lGap = 11
　　　　　　Case Is < 1:　　 lGap = 1
　　　　End Select
　　　　bSwt = False
　　　　For i = lLow To lUpr - lGap
　　　　　　If SortAsc Then
　　　　　　　　bFlg = IIf(CompStr, _
　　　　　　　　　　　 (StrComp(Src(i), Src(i + lGap), Compare) > 0), _
　　　　　　　　　　　 (Src(i) > Src(i + lGap)))
　　　　　　Else
　　　　　　　　bFlg = IIf(CompStr, _
　　　　　　　　　　　 (StrComp(Src(i), Src(i + lGap), Compare) < 0), _
　　　　　　　　　　　 (Src(i) < Src(i + lGap)))
　　　　　　End If
　　　　　　If bFlg Then
　　　　　　　　vTmp = Src(i)
　　　　　　　　Src(i) = Src(i + lGap)
　　　　　　　　Src(i + lGap) = vTmp
　　　　　　　　bSwt = True
　　　　　　End If
　　　　Next
　　Loop
End Sub

通報する