2006年04月10日月曜日

2006-04-10

Excel VBA Hacks (4)

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

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

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