個人的によく使うExcel VBAのコード覚え書き

2019.07.14

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

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

ファイルの処理

新規ブックを作成

Workbooks.Add

ブックとして開く

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
        MsgBox "キャンセルが押されました。" _
            & vbCrLf & "作業を中止します。"
        Exit Sub
    End If
End If

ブックと同一パスに指定のファイルがあればそのまま開き、無ければポップアップして選択し開く。

ブックを閉じる

Application.EnableEvents = False
ActiveWorkbook.Close SaveChanges:=True

閉じる際に出る何かしらのポップアップを拒否し、保存する場合のコード。

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

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つにまとめる時に使えます。

名前を付けて保存

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」が入力されます。

PDFとして出力

    Dim fileName As String
    Dim sheetName As String
    
    sheetName = ActiveSheet.Name
    If Application.OperatingSystem Like "*Mac*" Then
      ' Mac 向けの処理
      fileName = ThisWorkbook.Path & "/" & sheetName & ".pdf"
    Else
      ' Windows 向けの処理
      fileName = ThisWorkbook.Path & "\" & sheetName & ".pdf"
    End If
     
    With ActiveSheet.PageSetup
     
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
     
    End With
       
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=fileName

Macではフォルダの区切りが\ではなく/になるので、ファイル名をつける際にOSで分岐させます。

テキストファイルに出力

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

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

CSVやTSVを開いて配列に格納

Dim openFileName As String
Dim strBuf As Variant
Dim strArray As Variant
Dim setRow As Integer

openFileName = Application.GetOpenFilename("テキストファイル (*.txt),*.txt")

'CSVファイルの場合は "CSV（カンマ区切り）,*.csv"
    If openFileName <> "False" Then
        Open openFileName For Input As #1
    Else
        MsgBox "キャンセルが押されました。" _
            & vbCrLf & "作業を中止します。"
        Exit Sub
    End If

setRow = 1
Do Until EOF(1)    
    Line Input #1, strBuf
    If strBuf <> "" Then
        strArray = Split(strBuf, vbTab)
        
        For i = 0 To UBound(strArray)
            Cells(setRow, i+1).Value = strArray(i)
        Next
        setRow = setRow + 1
    End If
Loop
        
Close #1

ワークシートを探す

Dim ws As Worksheet
Dim sheetFlg As Boolean

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

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

表の最終行を取得し空白行を削除

Dim rowStart As Integer
Dim rowEnd As Integer
Dim colStart As Integer
Dim colEnd As Integer

'空白セルがある場合はここから
ActiveWorkbook.Worksheets(1).Range("A2").Select

rowStart = Selection.Row
rowEnd = Cells.SpecialCells(xlCellTypeLastCell).Row

colStart = Selection.Column
colEnd = Cells.SpecialCells(xlCellTypeLastCell).Column

'空白セルがない場合はここから
ActiveWorkbook.Worksheets(1).Range("A2").Select

startRow = Selection.Row
rowEnd = Selection.End(xlDown).Row

startCol = Selection.Column
rowCol = Selection.End(xlToRight).Column

基本はCtrl + Shift + ↓、あるいはCtrl + Shift + →の操作をした際の最終行・列を取得。

途中で空白セルがある場合はうまく機能しないためSpecialCellsを使う。

ソート

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 sample As String
Dim testFlg As Boolean

sampleFlg = False
If InStr(sample, "テスト") > 0 Then
    testFlg = True
End If

文字列を含んでいた場合1を返す。含んでいない場合は>を=にすればよい。

指定文字列より左側を取得

sample = Left(sample, InStr(sample, " "))

InStr関数の応用。Right関数を使えば右側を取得できる。

コピペ

Worksheets(1).Range("A2", "F" & i).Copy
Worksheets(2).Range("A2").PasteSpecial Paste:=xlPasteValues

このような場合、コピペするブックやシートがアクティブになった気がする（うろ覚え）

変数に格納して代入する場合はアクティブなブックやシートは変わらない。

置換

Range("A2", "A" & i).
Replace What:="/", Replacement:="", LookAt:=xlPart

Dim sample As String
sample = Replace(sample, "/", "")

2パターンあり、上はセル範囲の置換、下は変数の置換で使いやすい。

リストを作成する

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

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

罫線を引く

Range("A2", "E50").Borders.LineStyle = xlContinuous

シートを保護・解除する

/* 解除 */
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の引き数を変えることで日数や年・月・日・時・分・秒までいける。

CSVをTSVに変換

strArray = Split(csvToTsv(tmp(i)), vbTab)

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/

CSVのダブルクオーテーションを消す

str = Replace(str, """", "")

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

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
スポンサーリンク

コメント