VBA よく出てくる 関数群 (CSVファイルの読み込み / 出力)

VBAを記述する際に、頻発する処理を備忘録として残しておきます。

読み込みCSVファイル-ファイルパス取得 | 参照ダイヤログ呼び出し

Sub 参照ボタン_Click()

    Dim fType, prompt As String
    Dim fPath As Variant
    Dim ws As Worksheet
    Set ws = Worksheets("hoge")
    
    '選択できるファイルの種類をCSVに限定
    fType = "CSV ﾌｧｲﾙ (*.csv),*.csv"
    
    'ダイアログのタイトルを指定
    prompt = "CSVファイルを選択して下さい"
    
    'ファイル参照ダイアログの表示
    fPath = Application.GetOpenFilename(fType, , prompt)
    
    If fPath = False Then
        'ダイアログでキャンセルボタンが押された場合は処理を終了
        End
    End If
    
    'D3セルにファイル名をセット
    ws.Range("D3").Value = fPath

End Sub

画面描画ON/OFF

Sub メイン処理_Click()

    '画面更新停止
    Application.ScreenUpdating = False

    '--メイン処理--

    '画面更新再開
    Application.ScreenUpdating = True
    
end sub

CSVファイル存在チェック

    Dim csvFileFullPath As String    
    csvFileFullPath = ws.Range("D3").Value

    'CSVファイル-パス入力チェック
    If csvFileFullPath = "" Then
        MsgBox "CSVファイルを指定して下さい。", Buttons:=vbExclamation
        Exit Sub
    End If
    
    'CSVファイル-存在チェック
    If Dir(csvFileFullPath) = "" Then
        MsgBox "CSVファイルが指定されたパスに存在しません。", Buttons:=vbExclamation
        Exit Sub
    End If

CSVファイル読み込み→2次元配列に格納

    Dim csvFileFullPath As String
    Dim csvContents As String

    Dim csvData() As String
    Dim rowData() As String

    Dim rowCount As Long
    Dim colCount As Long

    Dim argCsvDataArray() As String
    
    csvFileFullPath = ws.Range("D3").Value
    
    'CSVファイルを一括読み込み
    Open csvFileFullPath For Binary As #1
    csvContents = Space$(LOF(1))
    Get #1, , csvContents
    Close #1
    
    '[行] - 改行コードで分割して配列に格納
    csvData = Split(csvContents, vbCrLf)
    
    '行数と列数を取得
    rowCount = UBound(csvData) - LBound(csvData) + 1
    colCount = UBound(Split(csvData(0), ",")) + 1

        '配列を再定義してデータを格納
    ReDim argCsvDataArray(1 To rowCount, 1 To colCount)
    
    '読み込み元CSVファイルを2次元配列に格納
    For i = 1 To rowCount - 1

        'ダブルクォーテーションに対応
        'replaceColonはWebより拝借 有益な情報ありがとうございます！
        rowData = Split(replace(replaceColon(csvData(i - 1)), """", ""), ":") 
                
        For j = 1 To colCount
            argCsvDataArray(i, j) = rowData(j - 1)
        Next j
    Next i

ファンクション - replaceColon

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

Function replaceColon(ByVal str As String) As String

    Dim strTemp As String
    Dim quotCount As Long

    Dim l As Long
    For l = 1 To Len(str)  'strの長さだけ繰り返す

        strTemp = Mid(str, l, 1) 'strから現在の1文字を切り出す

        If strTemp = """" Then   'strTempがダブルクォーテーションなら

            quotCount = quotCount + 1   'ダブルクォーテーションのカウントを1増やす

        ElseIf strTemp = "," Then   'strTempがカンマなら

            If quotCount Mod 2 = 0 Then   'quotCountが2の倍数なら

                '現在の1文字をコロンに置き換える
                str = Left(str, l - 1) & ":" & Right(str, Len(str) - l)   

            End If

        End If
    Next l

    replaceColon = str

End Function

配列から指定のヘッダー項目の列番号取得

'指定ヘッダー項目の列番号取得
'引数:対象配列,指定ヘッダー名
'存在しない場合､ゼロを返却
Function getHeaderColNum(ByRef argArray() As String, ByVal argHeaderStr As String) As Long

    Dim j As Long
    Dim endCol As Long                                '終了「列」
    
    endCol = UBound(argArray, 2)
    
    '1行目ヘッダーとする
    For j = 1 To endCol
        If argArray(1, j) = argHeaderStr Then
            getHeaderColNum = j
        End If
    Next j
    
End Function

文字列の桁数を6桁にゼロ埋めする

'取引先コード 桁数を合わせる (6桁ゼロ埋め)
Function setZeroPaddingSupplierCode(ByRef argArray() As String, ByVal argHeaderNum As Long) As String()

    Dim i As Integer                                   'ループ用変数「行」
    Dim j As Long                                      'ループ用変数「列」
    
    For i = 1 To UBound(argArray, 1)
        For j = 1 To UBound(argArray, 2)
        
            '1行目ヘッダー行
            If i <> 1 And j = argHeaderNum Then
                argArray(i, j) = Format(argArray(i, j), "000000")
            End If
            
        Next
    Next
    
    setZeroPaddingSupplierCode = argArray

End Function

CSVファイル出力のその前段処理の全貌 (プログレスバー制御も記載あり)

※「貸借区分」→ [0:貸],「1:借」元データ:改行されている
※　編集データ→ [0:貸],「1:借」は、横並びにする

'出力用配列作成
Function makeOutCsvData(ByRef argArray() As String, ByVal argHeaderTaisyakuCL As Long) As String

    Dim endRow As Long                                '終了「行」
    Dim endCol As Long                                '終了「列」
    
    Dim endLineCol As Long                            '出力用終了「列」
    
    Dim i As Integer                                   'ループ用変数「行」
    Dim j As Long                                      'ループ用変数「列」
    
    Dim Delimiter As String                            '区切り文字
    Dim enclosingLetter  As String                      '囲みの文字
       
    endRow = UBound(argArray, 1) - 1
    endCol = UBound(argArray, 2)
    endLineCol = (UBound(argArray, 2) - 1) * 2
    
    Delimiter = ","
    enclosingLetter = Chr(34)
    
    'プログレスバー設定
    UserForm1.ProgressBar1.Min = 1
    UserForm1.ProgressBar1.Max = endRow
    UserForm1.ProgressBar1.Value = 1
    
    
    '行
    For i = 1 To endRow
    'For i = 1 To 3
    
        '列
        For j = 1 To endCol
        
            '最終行制御
            If i = endRow And j = endLineCol Then
                makeOutCsvData = makeOutCsvData & enclosingLetter & argArray(i, j) & enclosingLetter
                GoTo NextLoop
            End If

            '最終列制御
            '「貸借区分」→ [0:貸],「1:借」
            If i <> 1 And argArray(i, argHeaderTaisyakuCL) = "0" And j = endCol Then
                makeOutCsvData = makeOutCsvData & enclosingLetter & argArray(i, j) & enclosingLetter & Delimiter
                GoTo NextLoop
                    
            ElseIf i <> 1 And argArray(i, argHeaderTaisyakuCL) = "1" And j = endCol Then
                makeOutCsvData = makeOutCsvData & enclosingLetter & argArray(i, j) & enclosingLetter & vbCrLf
                GoTo NextLoop
                    
            ElseIf i = 1 And j = endCol Then
                makeOutCsvData = makeOutCsvData & enclosingLetter & argArray(i, j) & enclosingLetter
                GoTo NextLoop
                    
            End If
                        
            makeOutCsvData = makeOutCsvData & enclosingLetter & argArray(i, j) & enclosingLetter & Delimiter
                    
NextLoop:
            
        Next j
        
        '1行目はヘッダー行 -複製する
        If i = 1 Then
            'makeOutCsvData = makeOutCsvData & enclosingLetter & argArray(i, j) & enclosingLetter & Delimiter
            makeOutCsvData = makeOutCsvData & Delimiter & makeOutCsvData & vbCrLf
        End If
        
        'プログレスバー行単位で更新
        If UserForm1.ProgressBar1.Min <= i And UserForm1.ProgressBar1.Max >= i Then
            UserForm1.ProgressBar1.Value = i
            UserForm1.Repaint
        End If
        
    Next i
    

End Function

CSVファイル出力と終了処理

'出力CSVファイルのパス - 読み込みCSVファイルと同階層
    outFileName = "〇〇〇〇〇〇〇〇" & Format(Now, "yyyymmdd_HHMMSS") & Extension
    outPathName = Left(csvFileFullPath, InStrRev(csvFileFullPath, "\")) & "\" & outFileName
    Open outPathName For Output As #1
    Print #1, outCsvContents
    Close #1
    
    '画面更新再開
    'Application.ScreenUpdating = True
    
    Unload UserForm1
    
    MsgBox "正常に処理が完了しました。" & Chr(13) & Chr(13) & "読み込み元のCSVファイルと同じ場所に出力してます。" & Chr(13) & Chr(13) & "出力ファイル名:" & Chr(13) & outFileName, vbInformation + vbOKOnly, "処理完了メッセージ"
    

備忘録に近いコード記述です。
何かのお役に立てたら幸いです。