朧の.Netの足跡
問合せ先:support@oborodukiyo.info サイト内検索はこちら
エクセルVBA 複数のファイルを一つのエクセルのシートにするVBA





ここで紹介するVBAは、CSVファイルやエクセルファイルの中の全てのシートを、このマクロが実行されるエクセルファイルの一つのシート(サンプルコードでのシート名はデータです)にコピーしてまとめるマクロです。
最初にSheet1のセルB1に、ワイルドカードを使って複数のファイルを指定するパスを書き込んでおきます。
拡張子で処理を分けています。
対応している拡張子は、CSVファイルが.csvと.txtで、エクセルファイルは.xlsと.xlsxです。
わかっている不具合は、エクセルファイルのデータをまとめた時に、「データ」シートの1行目には書き込まれないことです。
データ自体は2行目以降に全部書き込まれます。

こちらもどうぞ。
複数のファイルを一つのエクセルファイルにするVBA



Option Explicit

'
'複数のCSVファイルのテキストファイル、またはエクセルファイルを
'このマクロのあるエクセルファイルに1つのシートにまとめるVBAです。
'複数のファイルの指定はSheet1のセルB1にワイルドカードを使用して
'指定する。

'データをまとめるシートの変数
Dim dataSheet As Worksheet

Public Sub mergeFile()
    '検索するファイルのパス
    Dim strPath As String
    'ファイル名が入る変数
    Dim f As String
    'データをまとめるシートの取得
    Set dataSheet = ThisWorkbook.Worksheets("データ")
    'コピー先の行番号
    Dim row As Integer
    '行番号の初期化
    row = 1
    '複数のファイルを指定したワイルドカード使用のパスを取得
    '事前にSheet1のB1のセルに絶対パスで指定しておきます。
    '例 D:\Test\*.xlsx
    '例 D:\Test\*.csv
    strPath = ThisWorkbook.Worksheets("Sheet1").Range("B1").Value
    '指定されたパスのファイルを取得する。
    f = Dir(strPath, vbNormal)
    
    Do While f <> ""
        Dim strExt As String
        Dim pos As Integer
        'Dir関数ではファイル名だけなので、親フォルダのパスを付け加える
        f = Left(strPath, InStrRev(strPath, "\")) & f
        'ファイルの拡張子の位置を取得
        pos = InStrRev(f, ".")
        '拡張子を小文字にして取得
        strExt = LCase(Mid(f, pos + 1))
        '拡張子で処理を分ける
        Select Case strExt
        'テキストファイルで、中身はCSVのファイルを想定
        Case "txt"
            row = readCSVFile(row, f)
        'CSVファイルを想定
        Case "csv"
            row = readCSVFile(row, f)
        '拡張子がxlsのエクセルファイルを想定
        Case "xls"
            'エラー表示をさせない
            Application.DisplayAlerts = False
            'エラー表示を戻す
            Application.DisplayAlerts = True
            'エクセルファイルのシートをこのファイルへコピーする関数
            row = readXLSFile(row, f)
        Case "xlsx"
            'エラー表示をさせない
            Application.DisplayAlerts = False
            'エラー表示を戻す
            Application.DisplayAlerts = True
            'エクセルファイルのシートをこのファイルへコピーする関数
            row = readXLSFile(row, f)
        End Select
        
        '次のファイル名を取得する
        f = Dir()
    Loop
    
End Sub

Private Function readXLSFile(ByVal row As Integer, ByVal strFilePath) As Integer
    Dim wb As Workbook
    Dim s As Worksheet
    
    '開いたエクセルファイルを開いて、シートをコピーするためにインスタンスを取得する
    Set wb = Workbooks.Open(strFilePath)
    'すべてのシートでループする
    For Each s In wb.Worksheets
        'ここを変更
        With s
            .Range("A1").CurrentRegion.Copy Destination:=ThisWorkbook.Worksheets("データ").Range(ThisWorkbook.Worksheets("データ").Cells(ThisWorkbook.Worksheets("データ").Cells(Rows.Count, 1).End(xlUp).row + 1, 1), ThisWorkbook.Worksheets("データ").Cells(Rows.Count, Columns.Count))
        End With
    Next s
    
    wb.Close
    Set wb = Nothing
    row = dataSheet.Cells(dataSheet.Rows.Count, 1).End(xlUp).row + 1
    '次に書き込む行番号を返す
    readXLSFile = row
    
End Function

Private Function readCSVFile(ByVal row As Integer, ByVal strFilePath) As Integer
    'CSVファイルを読み込む
    readCSVFile = analyseCSV(row, strFilePath, "")
    
End Function

'メインの処理用関数
Private Function analyseCSV(ByVal row As Integer, ByVal fileName As String, ByVal quote As String) As Integer
    Dim fileNum As Integer
    Dim buf As String
    'カンマでスプリットした後の配列
    Dim arrLineData() As String
     
    Dim strSplit As String
    Dim i As Integer
    'クォートの長さ
    Dim length As Integer
     
    If fileName = "" Then
        analyseCSV = row
        Exit Function
    End If
     
    With dataSheet
    
        'クォーテーションの長さを取得しておく(汎用のため)
        length = Len(quote)
        strSplit = quote & "," & quote
        '空いているファイル番号を取得
        fileNum = FreeFile
         
        Open fileName For Input As #fileNum
         
        Do Until EOF(fileNum)
            Line Input #fileNum, buf
            '行の最初と最後の囲み文字を削除する処理
            buf = Left(buf, Len(buf) - length)
            buf = Right(buf, Len(buf) - length)
            '1行のデータを各項目に分解する処理
            arrLineData = Split(buf, strSplit)
             
            '何かの処理をしたい場合はここで処理を書き込む
            'do something
             
            'ワークシートのセルに書き込む
            For i = 0 To UBound(arrLineData)
                If quote = """" Then
                    arrLineData(i) = Replace(arrLineData(i), """""", """")
                End If
                .Cells(row, i + 1) = arrLineData(i)
            Next i
             
            'ワークシートの行番号をカウントアップする
            row = row + 1
        Loop
         
        Close #fileNum
        
        analyseCSV = row
    End With
End Function

        








良いやや良い普通やや悪い悪い

投稿日時評価コメント