' CSV Header Constants Const CSV_HEADER As String = "利用区間コード,券種,コード,名称,1箇月運賃/販売額,定期額/券1(額)/利用額,定期支給期間/券1(枚)/特別料金,特別料金/券2(額),券2(枚),端数(額),特別料金" Private Sub Worksheet_Change(ByVal Target As Range) ' === Fill D, E when C column changes === If Target.Column = 3 And Target.Row >= 7 Then Dim cell As Range For Each cell In Target If Trim(cell.Value) = "" Then Call ClearRowData(Me, cell.Row) Else Call FillFromKukanMaster(Me, cell.Row) End If Next End If End Sub Sub FillFromKukanMaster(ByVal ws As Worksheet, ByVal rowNum As Long, Optional ByVal setG As Boolean = True) Dim wsKukan As Worksheet Dim lastRow As Long Dim i As Long Dim code As String On Error Resume Next Set wsKukan = ThisWorkbook.Worksheets("M1") If wsKukan Is Nothing Then Exit Sub On Error GoTo 0 code = Trim(ws.Cells(rowNum, 3).Value) If code = "" Then Exit Sub lastRow = wsKukan.Cells(wsKukan.Rows.Count, 3).End(xlUp).Row For i = 7 To lastRow If Trim(wsKukan.Cells(i, 3).Value) = code Then ws.Cells(rowNum, 4).Value = Trim(wsKukan.Cells(i, 4).Value) & ": " & Trim(wsKukan.Cells(i, 5).Value) ws.Cells(rowNum, 5).Value = Trim(wsKukan.Cells(i, 6).Value) ws.Cells(rowNum, 6).Value = Trim(wsKukan.Cells(i, 7).Value) ws.Cells(rowNum, 7).Value = Trim(wsKukan.Cells(i, 9).Value) ws.Cells(rowNum, 8).Value = Trim(wsKukan.Cells(i, 14).Value) If setG Then ws.Cells(rowNum, 7).Value = "1" End If Exit Sub End If Next Call ClearRowData(ws, rowNum) End Sub Sub ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long) ' Clear from D column onwards ws.Range(ws.Cells(rowNum, 4), ws.Cells(rowNum, 15)).ClearContents ws.Cells(rowNum, 19).ClearContents ' Q column error info End Sub Sub ImportMasterDetailData() Dim filePath As String Dim fileDialog As FileDialog Dim wsTarget As Worksheet Dim stream As Object Dim textContent As String Dim lines As Variant Dim i As Long Dim dataArray As Variant Dim code As String Dim lastRow As Long Dim r As Long ' Target this worksheet Set wsTarget = Me ' === Step 1: Select CSV file === Set fileDialog = Application.FileDialog(msoFileDialogFilePicker) With fileDialog .Filters.Clear .Filters.Add "CSV Files", "*.csv" .AllowMultiSelect = False If .Show <> -1 Then Exit Sub filePath = .SelectedItems(1) End With ' === Step 2: Read CSV with Shift-JIS === Set stream = CreateObject("ADODB.Stream") With stream .Type = 2 .Charset = "shift_jis" .Open .LoadFromFile filePath textContent = .ReadText .Close End With lines = Split(textContent, vbLf) ' === Validate CSV header === If UBound(lines) >= 0 And Trim(lines(0)) <> "" Then Dim csvHeader As String csvHeader = Trim(lines(0)) ' Validate column count Dim expectedCount As Long expectedCount = UBound(Split(CSV_HEADER, ",")) + 1 Dim headerFields As Variant headerFields = Split(csvHeader, ",") If UBound(headerFields) + 1 <> expectedCount Then MsgBox "CSV column count mismatch. Expected: " & expectedCount & ", Got: " & UBound(headerFields) + 1, vbExclamation Exit Sub End If End If ' === Clear all data rows before import === lastRow = wsTarget.Cells(wsTarget.Rows.Count, "C").End(xlUp).Row If lastRow >= 7 Then wsTarget.Range("A7:P" & lastRow).ClearContents End If If UBound(lines) < 1 Then MsgBox "No data in CSV.", vbExclamation Exit Sub End If ' === Step 3: Collect CSV codes and data === Dim csvData As Object Set csvData = CreateObject("Scripting.Dictionary") For i = 1 To UBound(lines) If Trim(lines(i)) = "" Then GoTo NextCsvLine dataArray = Split(lines(i), ",") If UBound(dataArray) >= 0 Then code = CleanCSVField(CStr(dataArray(0))) If code <> "" Then ' Use unique key: code + "_" + row index to avoid duplicate key error csvData.Add code & "_" & i, dataArray End If End If NextCsvLine: Next i If csvData.Count = 0 Then MsgBox "No valid code found.", vbExclamation Exit Sub End If ' === Step 6: Write CSV data to next available row === writeRow = 7 For i = 1 To UBound(lines) If Trim(lines(i)) = "" Then GoTo NextLine dataArray = Split(lines(i), ",") ' CSV col 1 -> C column code = CleanCSVField(CStr(dataArray(0))) wsTarget.Cells(writeRow, 3).Value = code ' CSV col 2-11 -> G-P column If UBound(dataArray) >= 1 Then wsTarget.Cells(writeRow, 9).Value = CleanCSVField(CStr(dataArray(1))) If UBound(dataArray) >= 2 Then wsTarget.Cells(writeRow, 10).Value = CleanCSVField(CStr(dataArray(2))) If UBound(dataArray) >= 3 Then wsTarget.Cells(writeRow, 11).Value = CleanCSVField(CStr(dataArray(3))) If UBound(dataArray) >= 4 Then wsTarget.Cells(writeRow, 12).Value = CleanCSVField(CStr(dataArray(4))) If UBound(dataArray) >= 5 Then wsTarget.Cells(writeRow, 13).Value = CleanCSVField(CStr(dataArray(5))) If UBound(dataArray) >= 6 Then wsTarget.Cells(writeRow, 14).Value = CleanCSVField(CStr(dataArray(6))) If UBound(dataArray) >= 7 Then wsTarget.Cells(writeRow, 15).Value = CleanCSVField(CStr(dataArray(7))) If UBound(dataArray) >= 8 Then wsTarget.Cells(writeRow, 16).Value = CleanCSVField(CStr(dataArray(8))) If UBound(dataArray) >= 9 Then wsTarget.Cells(writeRow, 17).Value = CleanCSVField(CStr(dataArray(9))) If UBound(dataArray) >= 10 Then wsTarget.Cells(writeRow, 18).Value = CleanCSVField(CStr(dataArray(10))) ' Auto-fill D, E columns Call FillFromKukanMaster(wsTarget, writeRow, False) ' G column has value → trigger F dropdown writeRow = writeRow + 1 NextLine: Next i MsgBox writeRow - 7 & " rows imported.", vbInformation End Sub Function CleanCSVField(ByVal field As Variant) As String If IsEmpty(field) Or IsNull(field) Then CleanCSVField = "" Exit Function End If Dim result As String result = Trim(CStr(field)) If Len(result) >= 2 Then If Left(result, 1) = """" And Right(result, 1) = """" Then result = Mid(result, 2, Len(result) - 2) result = Replace(result, """""", """") End If End If CleanCSVField = result End Function Sub validateDetailData(ByVal ws As Worksheet, ByVal rowNum As Long) ' Check C column not empty If Trim(ws.Cells(rowNum, 3).Value) = "" Then ws.Cells(rowNum, 19).ClearContents Exit Sub End If ' Check G, H required and numeric (for composite key) If Trim(ws.Cells(rowNum, 9).Value) = "" Or Not IsNumeric(ws.Cells(rowNum, 9).Value) Then ws.Cells(rowNum, 19).Value = "G column (I) is required and must be numeric" Exit Sub End If If Trim(ws.Cells(rowNum, 10).Value) = "" Or Not IsNumeric(ws.Cells(rowNum, 10).Value) Then ws.Cells(rowNum, 19).Value = "H column (J) is required and must be numeric" Exit Sub End If ' Check I (K column) required If Trim(ws.Cells(rowNum, 11).Value) = "" Then ws.Cells(rowNum, 19).Value = "I column (K) is required" Exit Sub End If ' Check J, K required and numeric If Trim(ws.Cells(rowNum, 12).Value) = "" Or Not IsNumeric(ws.Cells(rowNum, 12).Value) Then ws.Cells(rowNum, 19).Value = "J column (L) is required and must be numeric" Exit Sub End If If Trim(ws.Cells(rowNum, 13).Value) = "" Or Not IsNumeric(ws.Cells(rowNum, 13).Value) Then ws.Cells(rowNum, 19).Value = "K column (M) is required and must be numeric" Exit Sub End If ' Check L-P optional but must be numeric if entered Dim col As Long Dim colName As String Dim colLetter As String colLetter = "NOPQR" For col = 14 To 18 If Trim(ws.Cells(rowNum, col).Value) <> "" And Not IsNumeric(ws.Cells(rowNum, col).Value) Then colName = Mid(colLetter, col - 13, 1) ws.Cells(rowNum, 19).Value = colName & " column must be numeric" Exit Sub End If Next col ' Check GH composite key duplicate Dim g As String, h As String Dim r As Long Dim lastRow As Long g = Trim(ws.Cells(rowNum, 9).Value) h = Trim(ws.Cells(rowNum, 10).Value) lastRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row For r = 7 To lastRow If r <> rowNum And Trim(ws.Cells(r, 3).Value) = Trim(ws.Cells(rowNum, 3).Value) Then If Trim(ws.Cells(r, 9).Value) = g And Trim(ws.Cells(r, 10).Value) = h Then ws.Cells(rowNum, 19).Value = "GH (I,J) combination already exists" Exit Sub End If End If Next r ' Validation passed ws.Cells(rowNum, 19).ClearContents End Sub ' Button macro (Validate selected row) Sub validateDetailDataButton() Dim ws As Worksheet Dim lastRow As Long Dim r As Long Dim errorCount As Long Set ws = ActiveSheet lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row If lastRow < 7 Then MsgBox "No data found.", vbExclamation Exit Sub End If errorCount = 0 For r = 7 To lastRow Call validateDetailData(ws, r) If Trim(ws.Cells(r, 19).Value) <> "" Then errorCount = errorCount + 1 End If Next r MsgBox "Validation complete. Errors: " & errorCount & ", ", vbInformation End Sub Sub ExportMasterDetailData() Dim ws As Worksheet Set ws = ActiveSheet Dim lastDataRow As Long lastDataRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row If lastDataRow < 7 Then MsgBox "No data rows to output.", vbExclamation Exit Sub End If Dim savePath As String savePath = Application.GetSaveAsFilename( _ FileFilter:="CSV Files (*.csv), *.csv", _ Title:="Save CSV") If savePath = "False" Then Exit Sub If InStr(1, savePath, ".csv", vbTextCompare) = 0 Then savePath = savePath & ".csv" End If ' Build header from row 5 (columns C, G-P) Dim csvContent As String csvContent = Trim(ws.Cells(5, 3).Value) Dim j As Long For j = 7 To 16 csvContent = csvContent & "," & Trim(ws.Cells(5, j).Value) Next j csvContent = csvContent & vbLf ' Row counter Dim rowCount As Long rowCount = 0 ' Data: C,G,H,I,J,K,L,M,N,O,P (skip D,E,F) Dim r As Long For r = 7 To lastDataRow If Len(Trim(ws.Cells(r, 3).Value & "")) > 0 Then rowCount = rowCount + 1 ' CSV col1 -> C column csvContent = csvContent & CleanCSVField(ws.Cells(r, 3).Value) ' CSV col2-11 -> I-R column For j = 9 To 18 csvContent = csvContent & "," & CleanCSVField(ws.Cells(r, j).Value) Next j csvContent = csvContent & vbLf End If Next r ' Trim trailing empty lines Do While Right(csvContent, 1) = vbLf csvContent = Left(csvContent, Len(csvContent) - 1) Loop ' Write file Dim stream As Object Set stream = CreateObject("ADODB.Stream") stream.Type = 2 stream.Charset = "shift_jis" stream.Open stream.WriteText csvContent, 1 stream.SaveToFile savePath, 2 stream.Close MsgBox "CSV export completed. Total data rows: " & rowCount, vbInformation End Sub