【Excel VBA】よく使うコードをまとめた個人的チートシート

僕がExcel VBAでプログラミングをする時によく使うコードをまとめました。僕自身がコピペして使うようです。

実際の成果物は下記のリンクから一覧で見られます。

Excel VBA
「Excel VBA」の記事一覧です。

ファイルを開く

Excelブックとしてファイルを開く

Excelブックとして開いて問題のないデータであれば、この方法が最も確実でわかりやすいです。

Sub sample()
    Dim openFileName As String  'ファイル名
    
    '開きたいファイルのパスと名前を指定
    openFileName = ThisWorkbook.Path & "\sample.csv"    'Macでは「\」ではなく「/」を使う
    
    'ファイルが見つからなければファイルを選択して開く
    If Dir(openFileName) = "" Then
        openFileName = Application.GetOpenFilename("CSV(コンマ区切り), *.csv")    'Macでは引数は記述しない
        
        'キャンセルボタンが押されたら処理中止
        If openFileName = "False" Then
            Exit Sub
        End If
    End If
    
    'ファイルを開く
    Workbooks.Open openFileName
    
    '処理を記述
    
    '開いたファイルを閉じる
    ActiveWorkbook.Application.CutCopyMode = False  'カットコピーモードを解除

    ActiveWorkbook.Close SaveChanges:=False         '開いたファイルを閉じる
End Sub

このマクロが記録されたExcelファイルと同じフォルダに「sample.csv」があれば開き、無ければユーザーがファイルを選択して開きます。プロシージャの最後で開いたファイルは保存せずに閉じます。

GetOpenFilenameメソッドの引数で開くファイル形式を限定することができます。以下の3つだけ使えればいいでしょう。

ちなみにこの引数はMacではエラーとなり指定できません。

ファイル形式引数
Excel(xls、xlsx、xlsm)Excel ブック,*.xls*
CSVファイルCSV(コンマ区切り),*.csv
テキストファイル(TSV)テキスト(タブ区切り),*.txt

CSVファイルをLine Inputで読み込む

Excelでは15桁を超える数値は扱えません。16桁以降はすべて0に変換されてしまいます。

16桁以降も正常に表示するには文字列として扱う必要があるのですが、そういったデータが含まれるCSVファイルをExcelで開いてしまうと変換後のデータしか取り出せません。

そこでLine Inputでテキストデータ読み込み、文字列としてExcelに出力するという方法があります。

Sub sample()
    Dim openFileName As String  'ファイル名
    Dim strLine As String       '1行分のデータ
    Dim strArray() As String    'カンマで分割したデータを格納
    
    '開きたいファイルのパスと名前を指定
    openFileName = ThisWorkbook.Path & "\sample.csv"    'Macでは「\」ではなく「/」を使う'
    
    'ファイルが見つからなければファイルを選択して開く
    If Dir(openFileName) = "" Then
        openFileName = Application.GetOpenFilename("CSV, *.csv")    'Macでは引数は記述しない'
        
        'キャンセルボタンが押されたら処理中止
        If openFileName = "False" Then
            Exit Sub
        End If
    End If
    
    '「1」としてファイルを開く
    Open openFileName For Input As #1
    
    '最後の行まで繰り返す
    Do Until EOF(1)
        Line Input #1, strLine   '1行分のデータを取得
        If strLine <> "" Then
            strArray = Split(strLine, ",")   'カンマで分割
            
            For i = 0 To UBound(strArray)   '1列ずつ処理
                '処理を記述'
                Debug.Print Replace(strArray(i), """", "")  'ダブルクォートを除去
            Next
            
        End If
    Loop
    
    Close #1    '閉じる
End Sub

なお、数値を文字列として処理するには文字列型で宣言した変数に格納したり、出力先セルの書式設定を文字列にしておくなどがありますが、勝手に数値に変えられてしまいがちです。

もっとも確実なのは頭に「’(シングルクォート)」を付けると強制的に文字列として扱われるので、「’ & strArray(i)」みたいな感じでセルに出力するといいと思います。

カンマ入りのCSVファイルをTSVファイルに変換する

CSVはComma Separated Valueの略で、要は「,(カンマ)」でデータを区切った形式です。

上記の方法ではSplit関数を使ってカンマでデータを分割していたのですが、区切りとしてはでなく文字列としてカンマが含まれていたら、値の途中でデータを区切ってしまうことになります。

エクセルVBAでデータにカンマが含まれてしまっているCSVを取り込む

そこで、こちらの記事を参考にし、区切りのカンマをタブ記号に変換してTSVにします。

Sub sample()
    Dim openFileName As String  'ファイル名
    Dim strLine As String       '1行分のデータ
    Dim strArray() As String    'タブ記号で分割したデータを格納
    
    '開きたいファイルのパスと名前を指定
    openFileName = ThisWorkbook.Path & "\sample.csv"    'Macでは「\」ではなく「/」を使う
    
    'ファイルが見つからなければファイルを選択して開く
    If Dir(openFileName) = "" Then
        openFileName = Application.GetOpenFilename("CSV, *.csv")    'Macでは引数は記述しない
        
        'キャンセルボタンが押されたら処理中止
        If openFileName = "False" Then
            Exit Sub
        End If
    End If
    
    '「1」としてファイルを開く
    Open openFileName For Input As #1
    
    '最後の行まで繰り返す
    Do Until EOF(1)
        Line Input #1, strLine   '1行分のデータを取得
        If strLine <> "" Then
            strArray = Split(csvToTsv(strLine), vbTab)   'タブ記号で分割
            
            For i = 0 To UBound(strArray)   '1列ずつ処理
                '処理を記述'
                Debug.Print Replace(strArray(i), """", "")  'ダブルクォートを除去
            Next
            
        End If
    Loop
    
    Close #1    '閉じる
End Sub

Function csvToTsv(ByVal 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

文字コードがUTF-8のCSVファイルを開く

Excelで文字コードがUTF-8のファイルを開くと文字化けします。

文字化けよさようなら!エクセルVBAでUTF-8のCSVを読み込む方法

こちらの記事を参考にし、ADODB.Streamというオブジェクトに入れて文字化けを避けます。

ADODB.Streamを使うには事前準備が必要です。

  1. VBEを起動
  2. メニューの「ツール」から「参照設定」を開く
  3. Microsoft ActiveX Data Objects ○.○ Libraryにチェックを入れる
Sub sample()
    Dim openFileName As String  'ファイル名
    Dim strBuf As String        '読み込んだデータ
    Dim strLine() As String     '1行分のデータ
    Dim strArray() As String    'カンマで分割したデータを格納
    
    '開きたいファイルのパスと名前を指定
    openFileName = ThisWorkbook.Path & "\sample.csv"    'Macでは「\」ではなく「/」を使う
    
    'ファイルが見つからなければファイルを選択して開く
    If Dir(openFileName) = "" Then
        openFileName = Application.GetOpenFilename("CSV, *.csv")    'Macでは引数は記述しない
        
        'キャンセルボタンが押されたら処理中止
        If openFileName = "False" Then
            Exit Sub
        End If
    End If
    
    'ADODB.Streamにデータを格納
    Set adoSt = CreateObject("ADODB.Stream")
    With adoSt
        .Charset = "UTF-8"
        .Open
        .LoadFromFile openFileName
        strBuf = .ReadText
        .Close
    End With
    
    '読み込んだデータを改行で区切る
    strLine = Split(strBuf, vbCrLf)
    
    'すべての行を処理
    For i = 0 To UBound(strLine)
        If strLine(i) <> "" Then
            strArray = Split(strLine(i), ",")   'カンマで分割
            
            '処理を記述
            Debug.Print Replace(strLine(0), """", "")
        End If
    Next
End Sub

MacでUTF-8のCSVファイルを読み込む

上記のADODB.StreamはMac版ではおそらく対応していません。

VBA CSV ファイルの読み込み (Workbooks.OpenText 関数を使う)

代替方法はこちらの記事を参考にしました。

Sub sample()
    Dim openFileName As String  'ファイル名
   
    '開きたいファイルのパスと名前を指定
    openFileName = ThisWorkbook.Path & "\sample.csv"    'Macでは「\」ではなく「/」を使う
    
    'ファイルが見つからなければファイルを選択して開く
    If Dir(openFileName) = "" Then
        openFileName = Application.GetOpenFilename("CSV, *.csv")    'Macでは引数は記述しない
        
        'キャンセルボタンが押されたら処理中止
        If openFileName = "False" Then
            Exit Sub
        End If
    End If
    
    'ファイルを開く
    Call Workbooks.OpenText(openFileName, Origin:=65001, Comma:=True)
    
    '処理を記述
    
    '開いたファイルを閉じる
    ActiveWorkbook.Application.CutCopyMode = False  'カットコピーモードを解除
    ActiveWorkbook.Close SaveChanges:=False         '開いたファイルを閉じる
End Sub

OpenTextメソッドの第2引数で開く文字コードを指定します。

文字コード
Shift-JIS932
UTF-865001

また、第3引数では区切り文字を指定できます。

区切り文字
カンマComma:=True
タブTab:=True
セミコロンSemicolon:=True
スペースSpace:=True
その他Other:=True, OtherChar:=”a”

ディレクトリ内のファイルを順番に開く

指定のディレクトリ内のファイルを順番に開く方法です。

VBA:フォルダ内のファイルを順次処理

こちらの記事を参考にしています。

Sub sample()
    Dim path, fso, file, files
    Dim wb As Workbook

    path = ThisWorkbook.path & "\sample"
    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
End Sub

マクロを記録したExcelファイルと同じディレクトリ内にある「sample」ディレクトリ内にあるファイルを順番に開きます。

ファイルを新規作成・保存する

新規ブックを作成して保存する

新規ブックを開いて保存します。また、既存のファイルを改めて名前を付けて保存することも可能です。

Sub sample()
    Dim tmpName As String       'デフォルトの保存名
    Dim saveFileName As String  '保存名
    
    '新規ブックを作成
    Workbooks.Add
    
    'デフォルトの保存名
    tmpName = "sample"
    
    '名前を付けて保存
    saveFileName = Application.GetSaveAsFilename(tmpName, FileFilter:="Excelファイル,*.xlsx,すべてのファイル,*.*")
    
    'キャンセルボタンを押されなければ保存
    If saveFileName <> "False" Then
        ActiveWorkbook.SaveAs Filename:=saveFileName, FileFormat:=xlNormal
    End If
End Sub

SaveAsメソッドのFileFormatでファイル形式を指定することができます。

ファイル形式
ExcelxlNormal
CSVxlCSV
テキストxlText

テキストファイルを作成して出力

テキストファイルとしてファイルを作成するのであれば、かなり処理が速いのでこのやり方がベストです。

Sub sample()
    Dim openFileName As String  'ファイル名
    
    openFileName = ThisWorkbook.Path & "\sample.txt"
    
    'テキストファイルを新規作成(存在していれば上書き)
    Open openFileName For Output As #1
    
    Print #1, "hoge"
    Print #1, "fuga"
    Print #1, "piyo"
    
    Close #1
End Sub

Printで1行ずつ追記していきます。

ワークシートの操作

シートを探す

Sub シートを探す()
    Dim sheetName As String

    sheetName = "サンプル"

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

指定の名前がついたシートが見つかればそのシートをアクティブにします。

シートの複製

Sub シートの複製()
    ActiveSheet.Copy Before:=ActiveSheet
End Sub

マクロ入りシートを複製しボタンに再登録

シートにマクロが記録されている場合、シートを複製すると登録名が前のシートのままになってしまいますので、複製したシート名で登録し直します。

Sub マクロ入りシートを複製しボタンに再登録()
    Dim macroName As String 'マクロ登録名
    
    Workbooks.Add
    ThisWorkbook.ActiveSheet.Copy Before:=ActiveWorkbook.Worksheets(1)

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

シートを削除

Sub シートを削除()
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
End Sub

シートを削除する前に警告メッセージが出てくるのを無効化する処理もしておきます。

シートの保護

Sub シートの保護()
    '保護の解除'
    ActiveSheet.Unprotect

    '保護
    ActiveSheet.Protect
End Sub

マクロ実行時のみシートの保護を解除

Sub マクロ実行時のみシートの保護を解除()
    ActiveSheet.Protect UserInterfaceOnly:=True
End Sub

テーブル

ソート

Sub ソート()
    Range(Cells(2, 1), Cells(100, 5)) _
    .Sort Key1:=Cells(2, 2), order1:=xlAscending, _
          Key2:=Cells(2, 3), order2:=xlDescending
End Sub

テーブルの先頭はヘッダー行ではなくデータが始まる行を指定します。

昇順xlAscending
降順xlDescending

セル

リストを作成する

Sub リスト作成()
    Dim listName As Name    'リスト名

    'リストが存在したら削除'
    For Each listName In ActiveWorkbook.Names
        If listName.Name = "サンプル" Then
            Range("サンプル").Name.Delete
        End If
    Next

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

条件付き書式

Sub 条件付き書式()
    '条件付き書式をリセット
    Range("A1").FormatConditions.Delete

    With Range("A1").FormatConditions.Add(Type:=xlTextString, String:="サンプル", TextOperator:=2)
        .Font.Color = RGB(255, 255, 255)    '文字色
        .Interior.Color = RGB(255, 0, 0)    '背景色
    End With
End Sub

FormatCondition.Addメソッドの引数で条件が変わります。

入力規則

Sub 入力規則()
    Dim myStr As String 'リストに登録する文字列'

    myStr = "ほげ,ふが,ぴよ"
    With Range("A1").Validation
        .Delete '入力規則をリセット'
        .Add Type:=xlValidateList, Formula1:=myStr
        .ShowError = False  '規則外の入力時のエラー表示'
    End With
End Sub

設定されている背景色をチェックする

Sub 背景色チェック()
    MsgBox Selection.Interior.Color
End Sub

背景色をクリアする

Range("A1").Interior.ColorIndex = 0

変数における処理

現在の日付を文字列として取得

Sub 現在の日付を文字列として取得()
    Dim todayDate As String
    todayDate = Format(Now, "yyyymmdd")
End Sub

日付の計算

Sub 日付の計算()
    Dim setDate As Date
    setDate = "2020/05/01"
    setDate = DateAdd("d", 3, setDate)
End Sub

setDateに3日足す例。

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

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

Sub 特定の文字以下の文字列を取り出す()
    Dim myStr As String

    myStr = "ほげ田 ほげ夫"
    myStr = Right(myStr, Len(myStr) - InStr(myStr, " "))
End Sub

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

アルファベットの大文字・小文字を区別しない

Sub 特定の文字以下の文字列を取り出す()
    Dim myStr As String

    myStr = "Hoge"
    Debug.Print UCase(myStr) & "," & LCase(myStr)
End Sub

大文字・小文字を区別しないというとニュアンスが違いますが、UCase関数はアルファベットをすべて大文字に変換します。

全角を半角にする

Sub 特定の文字以下の文字列を取り出す()
    Dim myStr As String

    myStr = "ほげホゲHoge"
    Debug.Print StrConv(myStr, vbNarrow)
End Sub

StrConv関数はさまざまな変換ができまして、第2引数をvbNarrowにすることで全角を半角にすることができます。

コメント

タイトルとURLをコピーしました