個人的によく使うExcel VBAマクロのコード備忘録

2019.07.14

VBA開発をする時、基本的で簡単なコードであれば覚えているのですが、たいていググるか昔のファイルを開いてコピペしちゃってます。

それで十分だとは思うのですが、その都度サイトやファイルを開くのがめんどくさいので、この記事にまとめておくことにしました。

内容リンク
月ごとの日付を算出Excelでカレンダーを自動作成するVBAマクロ
最終行・最終列の取得Excel VBAでシフト表自動作成ツール
シートの複製Excel VBAでシフト表自動作成ツール
配列の宣言・格納Excel VBAでシフト表自動作成ツール
Randomizeで配列内のデータをシャッフルExcel VBAでシフト表自動作成ツール
罫線の設定Excel VBAでシフト表自動作成ツール
IEを使い情報の取得と入力Excel VBAとIEでウェブページの情報を取得する
テーブルへ行追加【Excel VBA】週次集計と月間集計を作成する仕入・売上表
印刷範囲の設定【Excel VBA】週次集計と月間集計を作成する仕入・売上表
フィルタをかける【Excel VBA】週次集計と月間集計を作成する仕入・売上表
新規ブックを開く【Excel VBA】週次集計と月間集計を作成する仕入・売上表
セル範囲をコピペ【Excel VBA】週次集計と月間集計を作成する仕入・売上表
シートを削除【Excel VBA】週次集計と月間集計を作成する仕入・売上表
PDFに出力【Excel VBA】週次集計と月間集計を作成する仕入・売上表

ディレクトリ内のブックを順番に開いて処理

Dim path, fso, file, files
Dim wb As Workbook

path = ThisWorkbook.path & "\サンプルフォルダ"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set files = fso.GetFolder(path).files

For Each file In files
    Set wb = Workbooks.Open(file)
    /* 各ブックに対する処理 */
    Application.EnableEvents = False
    ActiveWorkbook.Close SaveChanges:=True
Next file

VBA：フォルダ内のファイルを順次処理を参考にしました。

複数のExcelブックを1つにまとめる時に使えます。

CSVファイルを開く

ブックとして開く

Dim openFileName As String

If Dir(ThisWorkbook.Path & "\sample.csv") <> "" Then
    Workbooks.Open ThisWorkbook.Path & "\sample.csv"
Else
    openFileName = Application.GetOpenFilename("CSV（カンマ区切り）,*.csv")
    If openFileName <> "False" Then
        Workbooks.Open openFileName
    Else
        Exit Sub
    End If
End If

Line Inputで読み込む

Dim openFileName As String
Dim strBuf As String
Dim strArray() As String

If Dir(ThisWorkbook.Path & "\sample.csv") <> "" Then
    openFileName = ThisWorkbook.Path & "\sample.csv"
Else
    openFileName = Application.GetOpenFilename("CSV（カンマ区切り）,*.csv")
    If openFileName = "False" Then
        Exit Sub
    End If
End If

Open openFileName For Input As #1

Do Until EOF(1)
    Line Input #1, strBuf
    If strBuf <> "" Then
        strArray = Split(strBuf, ",")
        MsgBox Replace(strArray(0), """", "")
    End If
Loop

Close #1

読み込んだCSVファイルを#1として扱い、1行ずつ処理していきます。

Split関数を使ってカンマで分割し配列に格納します。配列のインデックスは0番から始まるので注意するのと、データはダブルクォーテーションで囲まれているのでReplace関数で取り除きます。

Line Input（値にカンマが含まれている場合）

Sub sample()
    Dim openFileName As String
    Dim strBuf As String
    Dim strArray() As String
    
    If Dir(ThisWorkbook.Path & "\sample.csv") <> "" Then
        openFileName = ThisWorkbook.Path & "\sample.csv"
    Else
        openFileName = Application.GetOpenFilename("CSV（カンマ区切り）,*.csv")
        If openFileName = "False" Then
            Exit Sub
        End If
    End If
    
    Open openFileName For Input As #1
    
    Do Until EOF(1)
        Line Input #1, strBuf
        If strBuf <> "" Then
            strArray = Split(csvToTsv(strBuf), vbTab)
            MsgBox Replace(strArray(0), """", "")
        End If
    Loop
    
    Close #1
End Sub

Function csvToTsv(ByRef str As String) As String
    Dim strTemp As String
    Dim quotCount As Long
    Dim l As Long
    
    For l = 1 To Len(str)
        strTemp = Mid(str, l, 1)
        If strTemp = """" Then
            quotCount = quotCount + 1
        ElseIf strTemp = "," Then
            If quotCount Mod 2 = 0 Then
                str = Left(str, l - 1) & vbTab & Right(str, Len(str) - l)
            End If
        End If
    Next l
    
    csvToTsv = str
End Function

https://tonari-it.com/vba-csv-camma/

こちらの記事を参考にしました。

参考にした記事ではカンマをコロンに置き換えているのですが、コロンが含まれている場合のことを考えるとタブ記号に置換してTSVにしてしまうのがよいのではないかと思い少しアレンジしています。

CSVの文字コードがUTF-8の場合

Dim openFileName As String
Dim strBuf As String
Dim strLine() As String
Dim strArray() As String

If Dir(ThisWorkbook.Path & "\sample.csv") <> "" Then
    openFileName = ThisWorkbook.Path & "\sample.csv"
Else
    openFileName = Application.GetOpenFilename("CSV（カンマ区切り）,*.csv")
    If openFileName = "False" Then
        Exit Sub
    End If
End If

Set adoSt = CreateObject("ADODB.Stream")
With adoSt
    .Charset = "UTF-8"
    .Open
    .LoadFromFile openFileName
    strBuf = .ReadText
    .Close
End With

strLine = Split(strBuf, vbCrLf)

For i = 1 To UBound(strLine)
    If strLine(i) <> "" Then
        strArray = Split(strLine(i), ",")
        MsgBox (Replace(strLine(0), """", ""))
    End If
Next i

ExcelはUTF-8に対応していないので、ADODB.Streamというオブジェクトに入れて対応します。

https://tonari-it.com/vba-csv-utf8/

こちらの記事を参考にしました。

このADODB.Streamを使うにはVBEのツール→参照設定から、Microsoft ActiveX Data Objects ○.○ Libraryにチェックを入れる必要があります。たぶんMacは対応していません。

最後のFor文は1からスタートしていますが、ヘッダー行を飛ばすためであって配列は0始まりです。

UTF-8のTSVファイルを開く

Dim openFileName As String

If Dir(ThisWorkbook.Path & "\sample.csv") <> "" Then
    openFileName = ThisWorkbook.Path & "\sample.txt"
Else
    openFileName = Application.GetOpenFilename()
End If

If openFileName <> "False" Then
    Call Workbooks.OpenText(openFileName, Origin:=65001, Tab:=True)
Else
    Exit Sub
End If

TSVファイルはLine Inputで開けるのですが、UTF-8の場合はそのまま開くと文字化けしてしまいます。

TSVファイルをExcelブックとして開きます。文字コードによってOpenTextの引数を変えます。

あとはブックとしていつも通り処理すればOK。

【参考記事】https://www.tipsfound.com/vba/18015

名前を付けて保存

Dim saveFile As String
Dim saveName As String

saveName = "サンプル"

saveFile = Application.GetSaveAsFilename(saveName, FileFilter:="Excelファイル,*.xlsx,すべてのファイル,*.*")
ActiveWorkbook.SaveAs Filename:=saveFile, FileFormat:=xlNormal

'CSVの場合
saveFile = Application.GetSaveAsFilename(sheetName, FileFilter:="CSV（カンマ区切り）,*.csv")
ActiveWorkbook.SaveAs Filename:=saveFile, FileFormat:=xlCSV

ユーザが保存先や名前を自由に決められます。デフォルトでは「サンプル.xlsx」が入力されます。

テキストファイルに出力

txtFileName = ThisWorkbook.Path & "\sample.txt"
Open txtFileName For Output As #1
Print #1, "sample"
Print #1, "test"
Print #1, ThisWorkbook.Path
Close #1

指定したファイルがなければ作成します。

ワークシートを探す

Dim ws As Worksheet
Dim sheetFlg As Boolean

For Each ws In Worksheets
    If ws.Name = "サンプル" Then
        sheetFlg = True
    End If
Next

指定の名前がついたシートの存在を判定する。

ソート

Worksheets(1).Range(Cells(2, 1), Cells(100, 5)) _
    .Sort Key1:=Worksheets(1).Cells(2, 2), order1:=xlAscending, _
          Key2:=Worksheets(1).Cells(2, 3), order2:=xlDescending

ヘッダー行ではなくデータが始まる行を指定。

xlAscendingが昇順、xlDescendingが降順。

リストを作成する

Dim listName As Name
Dim a As Integer

a = 100

For Each listName In ThisWorkbook.Names
    If listName.Name = "サンプル" Then
        Range("サンプル").Name.Delete
    End If
Next

ActiveWorkbook.Names.Add _
    Name:="サンプル", _
    RefersTo:="=Sheet1!$A$2:$C$" & a

既にリストが存在していれば削除してから、新たにリストを作成する。

シートを保護・解除する

/* 解除 */
ActiveSheet.Unprotect
/* 保護 */
ActiveSheet.Protect

マクロ実行時のみ保護を解除する

ThisWorkbook.Worksheets("サンプル").Protect UserInterfaceOnly:=True

シートの枚数を数えて指定のシートをアクティブにする

Dim sheetCnt As Integer
sheetCnt = Worksheets.Count

For i = 1 To sheetCnt
    If sheetName = Worksheets(i).name Then
        Worksheets(i).Activate
        Exit For
    End If
Next

現時点の日付でマクロ実行ファイルと同じフォルダに保存

Dim thisPath As String
Dim todayDate As String

thisPath = ActiveWorkbook.Path
todayDate = Format(Now, "yyyymmdd")
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=thisPath & todaysDate & ".xlsx"
Application.DisplayAlerts = True

日付の計算

Dim setDate As date

setDate = "2020/05/01"
setDate = DateAdd("d", 3, setDate)
MsgBox(setDate)

setDateに３日足す例。

DateAddの引き数を変えることで日数や年・月・日・時・分・秒までいける。

特定の文字以下の文字列を取り出す

str = Right(str, Len(str)) - InStr(str, "$"))

頭に”$”があるデータから、$より右側を取得。

CSVファイルを作成→書き込み→閉じる

myPath = ThisWorkbook.Path
fileName = myPath & "\" & "sample.csv"
Open fileName For Output As #1
Print #1, str
Close #1

マクロ入りのシートをコピー、マクロ実行ボタンの参照先を変更

For i = 1 To ActiveSheet.DrawingObjects.Count
    ActiveSheet.DrawingObjects(i).Select
    namae = Selection.OnAction
    If InStr(namae, "!") > 0 Then
        namae = "'" & ActiveWorkbook.Name & "'!" & Mid(namae, InStr(namae, "!") + 1, Len(namae))
        ActiveSheet.DrawingObjects(i).OnAction = namae
    End If
Next

マクロ入りのシートをコピーした際、ボタンに登録されたマクロの参照先をコピー先にする処理です。

フォームを使用する

マクロの中でフォームを表示して値を取得します。

シートの一覧を表示して選択したシートをアクティブにし、ドロップダウンリストから年月を選択して変数に格納するというサンプルです。

標準モジュール

Sub formshow()

    On Error GoTo Err_frmShow

    Dim i As Integer
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name <> "サンプル" Then     'シート名が「サンプル」ならば表示しない
            UserForm1.ListBox1.AddItem (Worksheets(i).Name)
        End If
    Next i
    UserForm1.Show

Err_frmShow:
    Exit Sub

End Sub

Sub サンプル()
    Dim setYear As Integer
    Dim setMonth As Integer
    
    'フォームを表示
    Call formshow
    If ActiveSheet.Name = csvSheetName Then
        Exit Sub
    Else
        setYear = UserForm1.ComboBox1.Value
        setMonth = UserForm1.ComboBox2.Value
        Unload UserForm1
    End If
End Sub

フォーム

Private Sub CommandButton1_Click()
    UserForm1.Hide
End Sub

Private Sub CommandButton2_Click()
    Worksheets("サンプル").Activate
    Unload Me
End Sub

Private Sub ListBox1_Click()
    Index = ListBox1.ListIndex  'ワークシートリストの選択された位置
    Buf = ListBox1.List(Index)  'ワークシート名を取得
    Worksheets(Buf).Activate
End Sub

Private Sub UserForm_Initialize()
    Dim i As Long
        
    '年のコンボボックス　去年、今年、来年
    For i = Year(Date) - 1 To Year(Date) + 1
        ComboBox1.AddItem i
    Next
    '初期値は現在の年
    Select Case Month(Date)
        Case 12
            ComboBox1.Value = Year(Date) + 1
        Case Else
            ComboBox1.Value = Year(Date)
    End Select
    
    '月のコンボボックス　１２ヶ月
    For i = 1 To 12
        ComboBox2.AddItem i
    Next
    '初期値は現在の月
    ComboBox2.Value = Month(Date)
End Sub
スポンサーリンク

コメント