vba/vba_code_kukan_detail_master.txt

' CSV Header Constants
Const CSV_HEADER As String = "利用区間コード,券種,コード,名称,1箇月運賃/販売額,定期額/券１(額)/利用額,定期支給期間/券１(枚)/特別料金,特別料金/券２(額),券２(枚),端数(額),特別料金"

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("Kukan_Master")
    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