虎の巻

エクセルVBA虎の巻

この記事では、私がこれまでVBAを使用してきた中で「これは使える」と思ったコードを抜粋したものです

フォルダ選択

ファイルを保存するための保管フォルダを指定するダイアログボックスを表示します

Application.FileDialog プロパティを使用します

以下が一連のコードです

Sub folderSelect()

Dim str保存フォルダ名 As String

With Application.FileDialog(msoFileDialogFolderPicker)

*****Sponsered Link***** ************************

If .Show = 0 Then

MsgBox “フォルダ選択してください”

Exit Sub

Else

str保存フォルダ名 = .SelectedItems(1)

End If

End With

MsgBox str保存フォルダ名

End Sub

「.show=0」でフォルダが選択されていない場合は別途メッセージを表示します

ファイル保存

エクセルシートのCSV出力

出力したいシートをコピーして、新しいファイルを作成し、ファイル名を指定して保存します

ThisWorkbook.Worksheets(“出力”).Copy
ActiveWorkbook.SaveAs “D:\TEST.csv”, FileFormat:=xlCSV
ActiveWorkbook.Close

文字列操作

分割

文字列の分割にはSplitを使用します

Variant型で設定した変数をSplitで分割し、変数(0)、変数(1)、変数(2)で受け取ります

例えば、シートのB1セルに「600-1」の文字列があるとします

こちらの文字列を「-」で分割し、それぞれをメッセージで表示するとします

その場合は、次のコードで実現できます

Dim mySTRING As Variant
Dim myWORD As Variant
Dim myYEAR As String
Dim myMONTH As String

mySTRING = Worksheets(“Sheet1”).Range(“B2”).Value

myWORD = Split(mySTRING, “-“)

myYEAR = myWORD(0)

MsgBox myYEAR

myMONTH = myWORD(1)

MsgBox myMONTH

まず、myWORD(0)で600を取りだします

次にmyWORD(1)で1を取り出します

固定文字が含まれているかを判断する

Instr関数を使用し、０以上なら含まれていると判断します

Dim myCountWaritsuke As Long ‘固定の文字が含まれいる位置
myCountWaritsuke = InStr(“myTEST1”, “TEST”)

MsgBox myCountWaritsuke

上のコードの場合は、myTESTの文字列の3文字目にTESTの文字列が含まれているので3とメッセ―ジが出力されます

文字列への変換

数値の文字列への変換にはStr関数を使用します

Str関数を交えた下のコードを実行してみます

Dim myVal As Long

myVal = 1

Worksheets(“Sheet1”).Range(“B2”).Value = “A-” & Str(myVal)

するとB2セルに以下のような文字列が入力されます

ここで1点問題があります

半角の空白がStr関数で変換した文字列に入ってしまっています

こちらが気になる場合はCstr関数を使用します

Worksheets(“Sheet1”).Range(“B2”).Value = “A-” & CStr(myVal)

これで空白は入らないようになります

数値への変換

こちらはVal関数を使用します

Dim myVal As String

myVal = “1”

Worksheets(“Sheet1”).Range(“B2”).Value = Val(myVal) + 1

上のコードを実行すると「２」がB2セルに入力されます

数値かどうかの判定

対象の’文字’が数値かどうかの判定は「IsNumeric」を使用します

試しに次のコードを実行してみます

MsgBox IsNumeric(123)

そうすると次の画像のようにTRUEが出力されます

次に以下のコードを実行してみます

MsgBox IsNumeric(“TEST”)

この場合はFALSEが出力されます

注意して頂きたいのは、次の場合はTRUEが出力されます

MsgBox IsNumeric(“１２３”)

これはあくまで１２３が数値文字だからです

メール関連

表をメールの本文に入れる

シート内の表の内容をHTMにするのがポイントです

＊＊＊HTMLの作成＊＊＊

With Worksheets(“MAIL”)

myLast = .Cells(Rows.Count, 2).End(xlUp).Row

For i = 6 To myLast

myProduct = .Cells(i, 2).Value
myQuantity = .Cells(i, 3).Value
myPrice = .Cells(i, 4).Value

myData = myData & “” & “” & myProduct & “” & myQuantity & “” & myPrice & “”

Next

＊＊＊＊＊＊＊＊＊＊＊＊

そして、作成したHTMLをメールの本文に入れます（メールは送付せず、表示のみにしています）

*正確には事前に見出しを作成しておき、中身を変数で付け加える形です

‘メールの作成

       'OutlookのMailitemオブジェクトを取得する
          Dim objOutlook As New Outlook.Application
          Dim objMailitem As Outlook.MailItem
            Set objMailitem = objOutlook.CreateItem(olMailItem)

        'メールの各種設定をする
           With objMailitem
            .To = "analytic@analytic-vba.com"     '宛先
            '.CC = myCc     'CC
            .Subject = "TEST"
            '.SentOnBehalfOfName = mySenderAddress
            .HTMLBody = "<font face=""遊ゴシック""><font size=""2.5"">" & _
            "<body><table border=1><tr>" & "<th>Product</th><th>Quantity</th><th>Price</th>" & "　　
　　　　　　</tr>" & _
            myData & "</font></table></body>"

            .Display    '新規メール画面を表示

           End With 'objMailitem

これでエクセルシート内の表がメールの本文に入ります

ファイルを添付して送付

.Attachments.Add+ファイル名の一文を上記のコードに追加します

 Dim objMailitem As Outlook.MailItem
 Set objMailitem = objOutlook.CreateItem(olMailItem)
    
 'メールの各種設定をする
 With objMailitem
   .To = "analytic@vba.com"     '宛先
    （省略）
 　.Attachments.Add "C:\Users\＊＊＊\Downloads\download.csv"

   .Display    '新規メール画面を表示

 End With 'objMailitem

ユーザーフォーム

ユーザーフォームについてはこちらの記事もご参考にしてください

処理中表示

マクロの処理に時間がかかる場合は「処理中」の表示をしておきたい場合があります

こちらの表示にはユーザーフォームを使いたいところですが、ユーザーフォームを表示すると後続処理が止まってしまいます

ですので、以下のように「vbModeless」「Repaint」を使用します

Sub test()

UserForm1.Show vbModeless
UserForm1.Repaint

MsgBox “TEST”

Unload UserForm1

End Sub

上記のコードであれば、ユーザーフォームを表示しながらメッセージボックスも表示されます

ファイルの扱い

ファイルパスを指定して開く

Openメソッドを使用します

Dim myFileNameBefore As String

myFileNameBefore = “D:\Copy元.xlsx”

Workbooks.Open myFileNameBefore

ファイルを別名保存（コピー）する

SaveAsメソッドを使用します

Dim myFileNameBefore As String
Dim myFileNameAfter As String

myFileNameBefore = “D:\Copy元.xlsx”
myFileNameAfter = “D:\Copy先.xlsx”

Workbooks.Open myFileNameBefore

ActiveWorkbook.SaveAs Filename:=myFileNameAfter

ActiveSheet.Range(“B2”).Value = “TEST”

重複削除

重複削除を行うにはRemoveDuplicatesを使用します

複数列をキーに重複削除を行う際には、第二引数のArrayの中に列番号を複数指定します

例えば、次の表を「A」「B」の2列で重複削除を行うとします

この場合は、次のようなコードを書きます

Dim myLast As Long ‘最終行

myLast = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row

Range(“A1:C” & myLast).RemoveDuplicates (Array(1, 2))

これで次のように削除されます

シート操作

全ページ操作

ファイル内の全シートを一律に操作するには「For Each ~ in ~ Next」構文を使用します

次の画像では、各シートのA1セルに値が入っています

そして、シートB以外はA1セルの値を読んでメッセージを表示するようにします

コードは一度、シート変数：wsTESTを宣言した後に次のように書きます

For Each wsTEST In Worksheets

If wsTEST.Name <> “B” Then

wsTEST.Activate
MsgBox Range(“A1”).Value

End If

Next

ちなみにSheet変数.nameでシート名が取得できます

印刷設定

印刷範囲設定

Dim myLast As Long
‘最終行取得
myLast = Worksheets(“Sheet4”).Cells(Rows.Count, 1).End(xlUp).Row
With Worksheets(“Sheet4”).PageSetup


‘印刷範囲設定
.PrintArea = “A1:M” & myLast

End with

全列を全て印刷

Application.PrintCommunication = False
With Worksheets(“Sheet4”).PageSetup
‘*全ての列を印刷
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
Application.PrintCommunication = True

改ページプレビューに設定

ActiveWindow.View = xlPageBreakPreview

集約集計（Dictionary使用）

Dictionaryオブジェクトを使用すると、エクセル関数で言えばSUMIFSと同じ集計を簡単に行えます

このDictionaryオブジェクトの概要をまずは解説します

Addメソッド

Dictionaryは要は箱です

Addで物を仕分けながら箱に入れます

Existsメソッド

Existsメソッドを使用することで箱に入れるものの重複を確認しながら、箱の中に用意する仕分け用スペースを用意できるようになります

上記２つのメソッドを使用したのが次のサンプルコードです

＊＊＊Sample＊＊＊

Sub testDic_1201()

Dim myDic As Variant

Set myDic = CreateObject(“scripting.dictionary”)

myDic.Add “A”, 100
myDic.Add “B”, 150
myDic.Add “C”, 200

MsgBox “B ” & myDic.Exists(“B”) & ” 値：” & myDic(“B”)

End Sub

＊＊＊Sample＊＊＊

上記のコードを実行すると次のようなメッセージが表示されます

ここからサンプルコードについて詳細を解説します

Set myDic = CreateObject(“scripting.dictionary”)で箱を作成します

そしてAddメソッドで名前（Key）と値を組み合わせて箱に入れます

myDic.Add “A”, 100
myDic.Add “B”, 150
myDic.Add “C”, 200

名前（Key）があるので、箱の中で他の名前のものと区分されて仕分けられるイメージです

そして、myDic.Exists(“B”)によりBが箱にあるかどうかを判定します（⇒True）

Bの値についてはmyDic(“B”)でmyDicの箱から取り出します

ここから本題の集計集約について解説します

題材は以下の画像の表です

この表から次のような集約集計を行えるようにします

＊＊＊Sample＊＊＊

Dim myDic As Variant
Set myDic = CreateObject(“Scripting.Dictionary”)

Dim myData As Variant

myData = Worksheets(“Sheet4”).Range(“A1”).CurrentRegion

Dim i As Long

For i = 2 To UBound(myData)

①If Not myDic.Exists(myData(i, Dic列.名前)) Then
myDic.Add myData(i, Dic列.名前), myData(i, Dic列.値)

Else
②myDic(myData(i, Dic列.名前)) = myDic(myData(i, Dic列.名前)) + myData(i, Dic列.値)
End If
Next i

Dim myKey As Variant

③myKey = myDic.keys

④For i = 0 To UBound(myKey)

Worksheets(“Sheet4”).Cells(i + 1, 7).Value = myKey(i)
Worksheets(“Sheet4”).Cells(i + 1, 8).Value = myDic(myKey(i))

Next i

＊＊＊Sample＊＊＊

「①If Not myDic.Exists(myData(i, Dic列.名前)) Then」により名前：Keyが箱にあるかを判定し、名前から追加するか、それとも該当の名前に値を追加するかを選択します

該当の名前に値を追加する場合は以下で行えます

②オブジェクト（キー）＝オブジェクト（キー）＋値

これでmyDicという箱ができました

ここから箱の中の名前別に値を抽出します

まずは箱の中の名前の一覧を取得します

Dim myKey As Variant

③myKey = myDic.keys

そして、名前を一つ一つ処理していきます

④For i = 0 To UBound(myKey)

Worksheets(“Sheet4”).Cells(i + 1, 7).Value = myKey(i)
Worksheets(“Sheet4”).Cells(i + 1, 8).Value = myDic(myKey(i))

Next i

にほんブログ村 資格ブログ ビジネススキルへ

にほんブログ村

にほんブログ村 IT技術ブログ VBAへ

*****Sponsered Link***** ************************

シェア！

コメントを残す

メールアドレスが公開されることはありません。 ※ が付いている欄は必須項目です

Recommend関連記事

関連記事は見つかりませんでした。