vba/vba_code_kukan_detail_master.txt

Private Sub Worksheet_Change(ByVal Target As Range)
    ' === Generate F dropdown based on G column (matching left of colon) ===
    If Target.Column = 7 And Target.Row >= 7 Then
        If Target.Count > 1 Then Exit Sub
        Call MakeFDropdownByG(Me, Target.Row)
    End If
    
    ' === Extract left of colon to G column when F changes ===
    If Target.Column = 6 And Target.Row >= 7 Then
        If Target.Count > 1 Then Exit Sub
        If Trim(Target.Value) <> "" Then
            Dim fValue As String
            fValue = Trim(Target.Value)
            If InStr(fValue, ":") > 0 Then
                Target.Offset(0, 1).Value = Split(fValue, ":")(0)
                ' Don't trigger MakeFDropdownByG again - it's already set
            End If
        End If
    End If
    
    ' === Fill D, E when C column changes ===
    If Target.Column = 3 And Target.Row >= 7 Then
        If Trim(Target.Value) = "" Then
            Call ClearRowData(Me, Target.Row)
        Else
            Call FillFromKukanMaster(Me, Target.Row)
        End If
    End If
End Sub



Sub MakeFDropdownByG(ByVal ws As Worksheet, ByVal rowNum As Long)
    Dim wsKotsu As Worksheet
    Dim lastRowKotsu As Long
    Dim k As Long
    Dim kotsuList As String
    Dim kotsuA As String
    Dim kotsuB As String
    Dim gValue As String
    Dim fVal As String
    Dim targetCellF As Range
    
    gValue = Trim(ws.Cells(rowNum, 7).Value)
    fVal = Trim(ws.Cells(rowNum, 6).Value)
    
    ' Skip if F already has matching value (prevent loop)
    If fVal <> "" And InStr(fVal, ":") > 0 Then
        If Split(fVal, ":")(0) = gValue Then
            Exit Sub
        End If
    End If
    
    On Error Resume Next
    Set wsKotsu = ThisWorkbook.Worksheets("交通機関マスタ")
    On Error GoTo 0
    
    If wsKotsu Is Nothing Then Exit Sub
    If gValue = "" Then Exit Sub
    
    lastRowKotsu = wsKotsu.Cells(wsKotsu.Rows.Count, "A").End(xlUp).Row
    
    kotsuList = ""
    For k = 4 To lastRowKotsu
        kotsuA = Trim(wsKotsu.Cells(k, 1).Value)
        kotsuB = Trim(wsKotsu.Cells(k, 2).Value)
        If kotsuA <> "" Then
            If kotsuList <> "" Then kotsuList = kotsuList & ","
            kotsuList = kotsuList & kotsuA & ":" & kotsuB
        End If
    Next k
    
    Set targetCellF = ws.Cells(rowNum, 6)
    On Error Resume Next
    targetCellF.ClearContents
    targetCellF.Validation.Delete
    On Error GoTo 0
    
    If kotsuList <> "" Then
        On Error Resume Next
        targetCellF.Validation.Add Type:=xlValidateList, Formula1:=kotsuList
        targetCellF.Validation.IgnoreBlank = True
        targetCellF.Validation.ShowDropDownWhenSelected = True
        ' Auto select the first matching one
        For k = 4 To lastRowKotsu
            If Trim(wsKotsu.Cells(k, 1).Value) = gValue Then
                targetCellF.Value = gValue & ":" & Trim(wsKotsu.Cells(k, 2).Value)
                Exit For
            End If
        Next k
    End If
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, vbCrLf)
    
    ' === 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, 7).Value = CleanCSVField(CStr(dataArray(1)))
        If UBound(dataArray) >= 2 Then wsTarget.Cells(writeRow, 8).Value = CleanCSVField(CStr(dataArray(2)))
        If UBound(dataArray) >= 3 Then wsTarget.Cells(writeRow, 9).Value = CleanCSVField(CStr(dataArray(3)))
        If UBound(dataArray) >= 4 Then wsTarget.Cells(writeRow, 10).Value = CleanCSVField(CStr(dataArray(4)))
        If UBound(dataArray) >= 5 Then wsTarget.Cells(writeRow, 11).Value = CleanCSVField(CStr(dataArray(5)))
        If UBound(dataArray) >= 6 Then wsTarget.Cells(writeRow, 12).Value = CleanCSVField(CStr(dataArray(6)))
        If UBound(dataArray) >= 7 Then wsTarget.Cells(writeRow, 13).Value = CleanCSVField(CStr(dataArray(7)))
        If UBound(dataArray) >= 8 Then wsTarget.Cells(writeRow, 14).Value = CleanCSVField(CStr(dataArray(8)))
        If UBound(dataArray) >= 9 Then wsTarget.Cells(writeRow, 15).Value = CleanCSVField(CStr(dataArray(9)))
        If UBound(dataArray) >= 10 Then wsTarget.Cells(writeRow, 16).Value = CleanCSVField(CStr(dataArray(10)))
        
        ' Auto-fill D, E columns
        Call FillFromKukanMaster(wsTarget, writeRow, False)
        
        ' G column has value → trigger F dropdown
        If Trim(wsTarget.Cells(writeRow, 7).Value) <> "" Then
            Call MakeFDropdownByG(wsTarget, writeRow)
        End If
        
        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 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
    Dim deValue As String
    Dim fgValue As String
    
    On Error Resume Next
    Set wsKukan = ThisWorkbook.Worksheets("区間メンテナンス")
    On Error GoTo 0
    
    If wsKukan Is Nothing Then Exit Sub
    
    code = Trim(ws.Cells(rowNum, 3).Value)
    If code = "" Then Exit Sub
    
    lastRow = wsKukan.Cells(wsKukan.Rows.Count, "C").End(xlUp).Row
    
    Dim found As Boolean
    found = False
    
    For i = 7 To lastRow
        If Trim(wsKukan.Cells(i, 3).Value) = code Then
            deValue = Trim(wsKukan.Cells(i, 4).Value) & ": " & Trim(wsKukan.Cells(i, 5).Value)
            ws.Cells(rowNum, 4).Value = deValue
            
            fgValue = Trim(wsKukan.Cells(i, 6).Value) & "~" & Trim(wsKukan.Cells(i, 7).Value)
            ws.Cells(rowNum, 5).Value = fgValue
            
            If setG Then
                ws.Cells(rowNum, 7).Value = "1"
                Call MakeFDropdownByG(ws, rowNum)
            End If
            
            found = True
            Exit For
        End If
    Next
    
    If Not found Then
        Call ClearRowData(ws, rowNum)
        Exit Sub
    End If
    

    
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, 6).Validation.Delete
    ws.Cells(rowNum, 17).ClearContents ' Q column error info
End Sub

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, 17).ClearContents
        Exit Sub
    End If
    
    ' Check J, K required and numeric
    If Trim(ws.Cells(rowNum, 10).Value) = "" Or Not IsNumeric(ws.Cells(rowNum, 10).Value) Then
        ws.Cells(rowNum, 17).Value = "J column is required and must be numeric"
        Exit Sub
    End If
    
    If Trim(ws.Cells(rowNum, 11).Value) = "" Or Not IsNumeric(ws.Cells(rowNum, 11).Value) Then
        ws.Cells(rowNum, 17).Value = "K column 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 = "LMNOP"
    
    For col = 12 To 16
        If Trim(ws.Cells(rowNum, col).Value) <> "" And Not IsNumeric(ws.Cells(rowNum, col).Value) Then
            colName = Mid(colLetter, col - 11, 1)
            ws.Cells(rowNum, 17).Value = colName & " column must be numeric"
            Exit Sub
        End If
    Next col
    
    ' Check GHI composite key duplicate
    Dim g As String, h As String, i As String
    Dim r As Long
    Dim lastRow As Long
    
    g = Trim(ws.Cells(rowNum, 7).Value)
    h = Trim(ws.Cells(rowNum, 8).Value)
    i = Trim(ws.Cells(rowNum, 9).Value)
    
    If g <> "" And h <> "" And i <> "" Then
        lastRow = ws.Cells(ws.Rows.Count, "C").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, 7).Value) = g And _
                   Trim(ws.Cells(r, 8).Value) = h And _
                   Trim(ws.Cells(r, 9).Value) = i Then
                    ws.Cells(rowNum, 17).Value = "GHI combination already exists"
                    Exit Sub
                End If
            End If
        Next r
    End If
    
    ' Validation passed
    ws.Cells(rowNum, 17).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, 17).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
    
    ' Header:,1箇月運賃/販売額,定期額/券１(額)/利用額,定期支給期間/券１(枚)/特別料金,特別料金/券２(額),券２(枚),端数(額),特別料金
    Dim headerList As Variant
    headerList = Array("利用区間コード", "券種", "コード", "名称", "1箇月運賃/販売額", "定期額/券１(額)/利用額", "定期支給期間/券１(枚)/特別料金", "特別料金/券２(額)", "券２(枚)", "端数(額)", "特別料金")
    
    ' Build CSV
    Dim csvContent As String
    Dim j As Long
    
    For j = 0 To UBound(headerList)
        If j > 0 Then csvContent = csvContent & ","
        csvContent = csvContent & headerList(j)
    Next j
    csvContent = csvContent & vbCrLf
    
    ' 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 Trim(ws.Cells(r, 3).Value) <> "" Then
            ' CSV col1 -> C column
            csvContent = csvContent & CleanCSVField(ws.Cells(r, 3).Value)
            ' CSV col2-11 -> G-P column
            For j = 7 To 16
                csvContent = csvContent & "," & CleanCSVField(ws.Cells(r, j).Value)
            Next j
            csvContent = csvContent & vbCrLf
        End If
    Next r
    
    ' 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.", vbInformation
End Sub