関数は自分で作る

画像の一覧をセルのサイズに合わせて貼り付ける。A列に画像、B列にファイル名、C列にリンクしたフルパスを入れている。表形式なので並び替え／ソートもできる。次図は、前もってテーブル化している。テーブル化は、プログラムではなく先に設定した。追加した分も自動でテーブルになる。

mainのコード。流れは、削除、ファイルリスト作成、画像貼り付けの順。mainプロシージャの中で以下の３つ自作のプロシージャを使っている。

1. アクティブなシート内全部削除
2. myDir
3. instertImg2Cell

Sub main()
    On Error GoTo myErr
    アクティブなシート内全部削除 '自作Subプロシージャ
    Dim s As String
    s = myDir(Sheet1.Range("e1"), Range("e2")) '自作関数
    instertImg2Cell s, Range("a2") '自作Subプロシージャ
    Exit Sub
myErr: 'ラベル
    Debug.Print Err.Number, Err.Description
    Stop 'Stopステートメントでブレークポイントを設定
    Resume 'エラーのあった行へ移動
End Sub

画像とセルデータの両方を削除する。Shapeの名前を判断して、削除している。コマンドボタンとドロップボックスは除外する。このコードの元はマクロ記録で、知りたかったのはShapes、Delete、ClearContents。

Sub アクティブなシート内全部削除()
  Dim shp As Shape
  For Each shp In Excel.ActiveSheet.Shapes
    If VBA.InStr(shp.Name, "Button") Or VBA.InStr(shp.Name, "Drop ") Then'消したく無い
    Else
        shp.Delete
    End If
  Next shp
'  Cells.Clear
    Excel.Range("A2:C3000").ClearContents
    Excel.Range("a1").Select
 End Sub

myDir関数は、このページで作った関数を使う。

instertImg2Cell プロシージャは画像を扱う目的の処理。Shapes.AddPictureで画像をセルに入れる。使い方は、引数のヒントを参考にする。引数LinkToFileはリンクファイルになる。Excelファイル開いた時点でリンク先を開こうとする。引数SaveWithDocumentは、Excelのセルに画像データを保存するかどうか、Falseにすると引数LinkToFileがTrueの時に画像ファイルを呼び込む。False、Trueを指定する引数は、列挙型になっている。Falseは、リストから選ぶとmsoFalse、Trueはリストから選ぶとmsoTrueにしている。注意点は、最後の４つの引数にRangeオブジェクトからLeft,Top,Width,Heightを取り出している。画像が入る位置のポイント単位という単位で指定する。Topは必ず下のセルに表示するために位置を指定する。全部のセルの大きさが同じことを前提にしているため他の引数Left,Width,Heightは結果的に変化していない。AddPictureはShapeコレクションのメソッドです。

AddPicture( Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height )

画像の横にファイル名を、ActiveSheet.Hyperlinkでフルパスのハイパーリンクを入れる。

Sub instertImg2Cell(files As String, rStart As Range)
    Dim bb, rMove As Range
    bb = Split(files, vbCrLf) 'ファイル名の配列にする
    rStart.Select 'スタートのセルを選択
    Set rMove = rStart
    Dim i As Integer
    For i = 0 To UBound(bb)
        If 0 <> Len(bb(i)) Then
            ActiveCell.Offset(0, 1) = getFileName(bb(i))
            ActiveSheet.Hyperlinks.Add ActiveCell.Offset(0, 2), bb(i) 'ハイパーリンクで挿入
            Sheet1.Shapes.AddPicture ActiveCell.Offset(0, 2), msoTrue, msoTrue, rMove.Left, _
            rMove.Top, rMove.Width, rMove.Height  '画像の挿入
            Debug.Print rMove.Top 'Topだけは変わるので、挿入位置が変わる
            Set rMove = rMove.Offset(1, 0) 'AddPicture用のセル位置
            ActiveCell.Offset(1, 0).Select '次のセルへ
        End If
    Next
End Sub
'instertImg2Cell mydir(thisworkbook.Path,"*.png"), Range("a2")

マクロ記録で画像をセルに入れると、Pictures.Insert メソッドになる。「Pictures insert」で検索するとMicrosoftサポートでShapes. AddPictureメソッドを使うことが推奨されていた。Pictures.Insert メソッドの方が引数が少ないので使い方は簡単で、同様に動作するがここではAddPictureを使った。

フルパスからファイル名だけを取り出す関数。

Function getFileName(fullPathName) As String
    Dim ar
    ar = VBA.Split(fullPathName, "\")
    getFileName = ar(UBound(ar)) '配列の最後がファイル
End Function

以下は、イミディエイトウィンドウでgetFileNameを確認している。

?vba.CurDir
C:\Users\take\Documents
?getfilename(vba.CurDir)
Documents

Private Sub Workbook_Open()
    Sheet1.Range("f1") = VBA.Environ("homedrive") & VBA.Environ("homepath") & "\desktop"
    Sheet1.Range("f2") = VBA.Environ("homedrive") & VBA.Environ("homepath") & "\documents"
    Sheet1.Range("f3") = "c:\windows\system32"
End Sub

C列の画像データのファイルはリンクが張られている。 このハイパーリンクが開けないことがある。リンク先をクリックして以下のエラーが出たらpngの拡張子に対して使うアプリが正しく無い可能性がある。Windowsはファイルをクリックしてファイルの拡張子ごとにアプリを開く機能のある。

スマホの方は、ここをクリックするYouTubeで見れます。

私の場合は、原因はわからないが、アプリのインストール時に拡張子に対応するアプリを登録、その後アプリをアンインストールしたか何かだろう。png、jpg、gifが該当のアプリ無しで次の図のエラー。bmpはペイントブラシが起動した。ペイントブラシがあるので基本的に png、jpg、gif もペイントブラシが起動してくれればいいいがエラーになる。

regeditを実行して

私の場合は、選択しているpngを削除したらペイントブラシが起動できるようになる。レジストリの変更や削除は危険なのでおすすめはしない。 pngをpng123とか適当な名前に変えたらペイントブラシが起動するはず。 でも、削除方式をしたので名前変更方式は未確認。

あるフォルダにある全ExcelファイルをA列のセルに入れるプロシージャを作る。以下を、標準モジュールに書く。

Sub dir2Cell()
    Dim r As Range
    Set r = Range("a1") '選択しているシートのA1セルをr変数にSet
    r.Value = VBA.Dir("*.xl*") 'カレントフォルダのエクセルファイル
    Dim i As Integer
    Do Until "" = r.Offset(i, 0)    'iは0から始まる
        i = i + 1
        r.Offset(i, 0) = VBA.Dir 'Dirの繰り返し
    Loop
End Sub

Sub dir2cell range(“a1”)からEnd Subの間にマウスでクリック、カーソルを置いてから実行ボタン▶を押して実行する。今、選択しているワークシートのセルA1から下にエクセルのファイル名が入る。

セルA列のファイルをセルB列の名前で保存するプロシージャを作る。B列に変更するファイル名を入れる。次図のようにB列に入れると、1.xls->a.xls,2.xlsx->b.xlsにコピーする。

プログラムでは、A１のセルから下向きに何も入ってないセルまで実行する。

プログラムの実行時に、セルA1を選択（ActveCell）にして、bookCopyのプロシージャ内にマウスを置いて実行ボタン▶を押す。

'コピーを開始するファイル名があるセルを先に選択しておく
Sub bookCopy()
    Dim r As Range, i As Integer
    Set r = Excel.ActiveCell '選択しているセルのオブジェクトをr変数にセットする
    Do
        VBA.FileCopy r.Offset(i, 0), r.Offset(i, 1)
        i = i + 1
    Loop Until "" = r.Offset(i, 0)'何も入ってないともうファイルは無いので終える
End Sub

次図は、エクスプローラーで結果確認。

もし、Excelで開いているファイルをFileCopyしようとするとエラーで止まる。

移動の処理にする場合は、元のファイルを削除すればいい。Killコマンドで削除する。ファイル名を変数に入れて、その都度その変数名でKillすればいい。

'削除をするファイル名があるセルの列の一番上を選択しておく
Sub delA1()
    Dim r As Range, i As Integer
    Set r = Excel.ActiveCell '選択しているセルのオブジェクトをr変数にセットする
    Do
        Debug.Print "削除するファイル名：" & r.Offset(i, 0)
        Stop '実行ボタンを押すとかF8で次に進む
        VBA.Kill r.Offset(i, 0) '削除
        i = i + 1
    Loop Until "" = r.Offset(i, 0) '何も入ってないともうファイルは無い
End Sub

1.xlsと2.xlsxの２つのファイルが消えます。Sub delA1からEnd Subの間にカーソルを移動してから実行ボタン▶かF8（ステップ実行）を押すと「削除するファイル名：1.xls」がイミディエイトウィンドウに出力されてStopステートメントで中断中になる。この時点で1.xls ファイルが無くなっている。さらに実行ボタン▶かF8を押す と「 削除するファイル名：2.xlsx」がイミディエイトウィンドウに出力されて中断中になる。