お世話になります。
下記のコードで異なる二つのCSVを取り込み、キー情報が一致したレコードをCSV1の最終列に続けて書き出すマクロを作成しております。
キー情報が一致しているにもかかわらず書き出しが行われなく頭を抱えております。
ご教示のほどよろしくお願いします。
Public Sub MergeCSV()
'CSV1取り込み
MsgBox "CSV1を選択してください。", vbOKOnly + vbInformation
'CSVファイルデータの配列情報を取得
Dim csvData1 As Variant 'CSV1配列
Dim r_Count1 As Long
Dim c_Count1 As Long
csvData1 = CSVtoArray(GetFilePath)
If IsEmpty(csvData1) Then Exit Sub
r_Count1 = UBound(csvData1, 1)
c_Count1 = UBound(csvData1, 2)
'CSV1データをシートに張り付け
ThisWorkbook.Sheets(1).cells.Clear
Sheets(1).Activate
Range("A1").Resize(r_Count1, c_Count1).NumberFormat = "@"
Range("A1").Resize(r_Count1, c_Count1).Value = csvData1
'CSV2取り込み
MsgBox "CSV2を選択してください。", vbOKOnly + vbInformation
Dim csvData2 As Variant 'CSV1配列
Dim r_Count2 As Long
Dim c_Count2 As Long
csvData2 = CSVtoArray(GetFilePath)
If IsEmpty(csvData2) Then
MsgBox "CSV2の取り込みに失敗しました。" & vbCrLf & "プログラムを終了します。", vbOKOnly + vbInformation
ThisWorkbook.Sheets(1).cells.Clear
Exit Sub
End If
r_Count2 = UBound(csvData2, 1)
c_Count2 = UBound(csvData2, 2)
'CSVマージ
Dim k As Long
Dim l As Long
Dim m As Long
For k = 2 To r_Count1
For l = 2 To r_Count2
With ThisWorkbook.Sheets(1)
If .cells(k, 1).Value = csvData2(l, 1) And .cells(k, 2).Value = csvData2(l, 2) And .cells(k, 28).Value = csvData2(l, 6) Then
For m = 1 To c_Count2
.cells(k, .cells(1, .Columns.Count).End(xlToLeft).Column + 1).NumberFormat = "@"
.cells(k, .cells(1, .Columns.Count).End(xlToLeft).Column + 1).Value = csvData2(l, m)
Next m
Exit For
Else
MsgBox "CSVが一致しません。再度CSVファイルを出力してください。", vbOKOnly + vbInformation
Exit Sub
End If
End With
Next l
Next k
MsgBox "処理が完了しました。"
End Sub
Public Function GetFilePath() As String
Dim path As String 'ファイルパス
path = Application.GetOpenFilename(Title:="ファイルを選択", filefilter:="csvファイル,*.csv")
If path = "False" Then Exit Function
GetFilePath = path
End Function
Public Function CSVtoArray(ByVal filePath As String) As Variant
Dim csvAry As Variant
Dim lineData As String
Dim fileNum As Long
fileNum = FreeFile
'行列数取得
Dim rowCount As Long
Dim colCount As Long
Dim dataAry As Variant
If filePath = "" Then Exit Function
Open filePath For Input As #fileNum
Do Until EOF(fileNum)
Line Input #fileNum, lineData
rowCount = rowCount + 1
dataAry = Split(lineData, ",")
If rowCount = 1 Then
colCount = UBound(dataAry) + 1
End If
Loop
Close #fileNum
'二次元配列を定義
ReDim csvAry(1 To rowCount, 1 To colCount) As Variant
'データを配列に格納
Dim i As Long
Dim j As Long
Open filePath For Input As #fileNum
Do Until EOF(fileNum)
Line Input #fileNum, lineData
dataAry = Split(lineData, ",")
i = i + 1
For j = 0 To UBound(dataAry)
csvAry(i, j + 1) = RTrim(dataAry(j))
Next j
Loop
Close #fileNum
'戻り値を定義
CSVtoArray = csvAry
End Function
