Excel VBA Hacks (4)

前回まではテキスト処理を中心に書いてきたが、Excelと言えばワークシートを使ってなんぼ。ということで、ワークシートを使うお題から。先日つらつら仕事をしていて、Excelで書いた表の升目の大きさに合わせて、写真を貼らなければならない資料を作る必要が生じた。まぁ数枚だったら適当に貼り付けるのだが、さすがに貼り付ける写真の枚数が総数で400枚を越えると考えも変えざるえない。貼る時間よりマクロを書く方が数段速いので、サクサクこんなツールを書いてみる。

```vbnet InsertImages.bas Option Explicit

Sub InsertImages()

Dim FileName As String
Dim c, cs As Range
Dim fs As Object

Set fs = CreateObject("Scripting.FileSystemObject")
Set cs = Selection

For Each c In cs

    FileName = c.Value

    If fs.FileExists(FileName) = True Then

        c.Value = ""

        With ActiveSheet.Pictures.Insert(FileName)
            .ShapeRange.LockAspectRatio = msoTrue
            .ShapeRange.Height = c.Height - 2   ' 画像の高さをセルの高さに適当に合わせる
            .ShapeRange.Width = c.Width - 2     ' 画像の幅をセルの幅に適当に合わせる
            .ShapeRange.Top = c.Top + 1         ' 画像の上側の辺をセルの上側の辺に適当に合わせる
            .ShapeRange.Left = c.Left + 1       ' 画像の左側の辺をセルの左側の辺に適当に合わせる
        End With

    End If

Next c

End Sub ```

使い方は、写真を張り込みたい表を作ってしまって、写真を貼り付けたいセルに貼り付けたい写真のファイル名をフルパスで入力。あとは写真を貼りたいセルをすべて選択して上のマクロを実行。あっという間に作業は終了。ちなみに写真はセルに対して貼り付けられる訳ではなくワークシートに対して貼り付けられるので、貼り付けるときに必要な座標は大きさはワークシートの左上を原点とした座標(ポイントが単位)。貼りたい場所と大きさはファイル名を書き込んだセルの位置と大きさを知れば良いというのが、このマクロのありがたいところ。リストも簡単だし、だれでも理解できるように書いてみた。

あといっぱいファイルがあるので、入力するのがめんどくさいという無精な人(僕のことか)のために、ファイル名のリストをセルに書き出すマクロも付けておこう。このマクロを新規のシートで実行すると、「ファイルを開く」ダイアログボックスが出て、そこで処理したいファイルを全部選択(適当なディレクトリに入れておいて全部選択すれば簡単ね)してOKボタンを押すと、ファイル名を昇順ソートして出力するから、これをコピぺするとよろしい。

Option ExplicitSub getFilenames()Dim astrFilename As VariantDim test As CollectionastrFilename = Application.GetOpenFilename _(FileFilter:="JPEGファイル(*.JPG;*.JPEG;*.JPE),*.JPG;*.JPEG;*.JPE,TIFFファイル(*.TIF),*.TIF,PNGファイル(*.PNG),*.JPG,すべてのファイル(*.*), *.*", _Title:="必要なファイルを選択して,「開く」ボタンを選択してください。「カンマ(,)」と「コロン (:)」で区切ります。", _MultiSelect:=True)If IsArray(astrFilename) = False ThenIf astrFilename = False ThenMsgBox "「キャンセル」ボタンを選択しました"End IfElseDim FileNames() As StringDim i As IntegerDim SortRange As RangeReDim FileNames(UBound(astrFilename))For i = 1 To UBound(astrFilename)ActiveSheet.Cells(i, 1).Value = CStr(astrFilename(i))Next i' ファイル名を昇順に並び替えSet SortRange = Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, 1).End(xlDown))SortRange.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _SortMethod:=xlPinYin, DataOption1:=xlSortNormalEnd IfEnd Sub

適当にレイアウトして欲しいと言う意見はあるかもだけども、僕の用途ではいつも行数と列数が一定ではなく、ころころ変わることもあり、これで十分と言うことで、あとの改良は読者へのの宿題としたい。(おもしろいのを作ったら教えてくださいな。)

軽井沢ミーティング2018に参加

軽井沢ミーティング2018に初参加! 天気良くてよかった!さすがに5月末の週末は本当に天気が良い。Roadsterのイベントは前日入り出来る場合は可能な限り前日から参加している。主催者発表による今回の参加者は1975人、車はは1,002台。内訳は、NAは37%、NBは22%...… Continue reading

2017年も今日でおしまい

Published on December 31, 2017

Profoto A1の色温度の話

Published on December 21, 2017