エクセルでのマクロ

質問

素朴な質問なんですが…
エクセルで写真を整理したいんです（一列に並べたり，写真のサイズを合わせたり…等）
ウスウス聞いたことがあるんですが、このときコントロールキーとQを押すだけで，指定されたフォルダからの写真がエクセルで貼り付けることができるらしい…写真は予め設定したエクセルのセルのサイズに合わせて貼り付けられるんです。
このやり方知っている方はいらっしゃいますか？ぜひ教えてください。
もし違うやり方でもいいんですが、何枚かの写真をエクセルで貼り付けて、サイズを合わせて効率的に整理することができる方法を知っている方、ぜひその方法教えてください。
宜しくお願いします。

回答No.1

KenKen_SP

こんにちは。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