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 Target.Count > 1 Then
            ' Handle multiple cells
            Dim cell As Range
            For Each cell In Target
                If cell.Column = 3 And cell.Row >= 7 Then
                    If Trim(cell.Value) = "" Then
                        Call ClearRowData(Me, cell.Row)
                    Else
                        Call FillFromKukanMaster(Me, cell.Row)
                    End If
                End If
            Next cell
            Exit Sub
        End If
        
        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)
    
    If UBound(lines) < 1 Then
        MsgBox "No data in CSV。", vbExclamation
        Exit Sub
    End If
    
    ' === Step 3: Collect CSV codes and data (include all columns including コード and 券種) ===
    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列
        code = CleanCSVField(CStr(dataArray(0)))
        wsTarget.Cells(writeRow, 3).Value = code
        
        ' CSV col 2-11 -> G-P列
        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 from 区間メンテナンス
        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("区間メンテナンス")
    
    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, Optional ByVal isImport As Boolean = False)
    ' Disable screen update and calculation for performance
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Dim cValue As String
    Dim jValue As String
    Dim kValue As String
    Dim lValue As String
    Dim mValue As String
    Dim nValue As String
    Dim oValue As String
    Dim pValue As String
    Dim gValue As String
    Dim hValue As String
    Dim iValue As String
    Dim i As Long
    Dim lastRow As Long
    Dim errorMsg As String
    
    cValue = Trim(ws.Cells(rowNum, 3).Value)
    If cValue = "" Then
        ws.Cells(rowNum, 17).Value = ""
            Exit Sub
    End If
    
    ' === J and K columns must be numeric (required) ===
    jValue = Trim(ws.Cells(rowNum, 10).Value)
    kValue = Trim(ws.Cells(rowNum, 11).Value)
    
    If jValue = "" Then
        errorMsg = "J列は必須項目です。"
        ws.Cells(rowNum, 17).Value = errorMsg
        Exit Sub
    End If
    
    If Not IsNumeric(jValue) Then
        errorMsg = "J列must be numeric。"
        ws.Cells(rowNum, 17).Value = errorMsg
        Exit Sub
    End If
    
    If kValue = "" Then
        errorMsg = "K列は必須項目です。"
        ws.Cells(rowNum, 17).Value = errorMsg
        Exit Sub
    End If
    
    If Not IsNumeric(kValue) Then
        errorMsg = "K列must be numeric。"
        ws.Cells(rowNum, 17).Value = errorMsg
        Exit Sub
    End If
    
    ' === L, M, N, O, P columns must be numeric if entered ===
    lValue = Trim(ws.Cells(rowNum, 12).Value)
    mValue = Trim(ws.Cells(rowNum, 13).Value)
    nValue = Trim(ws.Cells(rowNum, 14).Value)
    oValue = Trim(ws.Cells(rowNum, 15).Value)
    pValue = Trim(ws.Cells(rowNum, 16).Value)
    
    If lValue <> "" And Not IsNumeric(lValue) Then
        errorMsg = "L列must be numeric。"
        ws.Cells(rowNum, 17).Value = errorMsg
        Exit Sub
    End If
    
    If mValue <> "" And Not IsNumeric(mValue) Then
        errorMsg = "M列must be numeric。"
        ws.Cells(rowNum, 17).Value = errorMsg
        Exit Sub
    End If
    
    If nValue <> "" And Not IsNumeric(nValue) Then
        errorMsg = "N列must be numeric。"
        ws.Cells(rowNum, 17).Value = errorMsg
        Exit Sub
    End If
    
    If oValue <> "" And Not IsNumeric(oValue) Then
        errorMsg = "O列must be numeric。"
        ws.Cells(rowNum, 17).Value = errorMsg
        Exit Sub
    End If
    
    If pValue <> "" And Not IsNumeric(pValue) Then
        errorMsg = "P列must be numeric。"
        ws.Cells(rowNum, 17).Value = errorMsg
        Exit Sub
    End If
    
    ' === Check G, H, I composite key for duplicates ===
    gValue = Trim(ws.Cells(rowNum, 7).Value)
    hValue = Trim(ws.Cells(rowNum, 8).Value)
    iValue = Trim(ws.Cells(rowNum, 9).Value)
    
    If gValue <> "" And hValue <> "" And iValue <> "" Then
        lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
        
        For i = 7 To lastRow
            If i <> rowNum Then
                If Trim(ws.Cells(i, 3).Value) = cValue Then
                    If Trim(ws.Cells(i, 7).Value) = gValue And _
                       Trim(ws.Cells(i, 8).Value) = hValue And _
                       Trim(ws.Cells(i, 9).Value) = iValue Then
                        errorMsg = "GHI列combination already exists。"
                        ws.Cells(rowNum, 17).Value = errorMsg
                        Exit Sub
                    End If
                End If
            End If
        Next i
    End If
    
    ' Validation passed, clear Q column error
    ws.Cells(rowNum, 17).Value = ""
    
    ' Restore settings
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

' 按钮调用的宏（Validate selected row）
Sub validateDetailDataButton()
    Dim rowNum As Long
    rowNum = ActiveCell.Row
    
    If rowNum < 7 Then
        MsgBox "データ行を選択してください。", vbExclamation
        Exit Sub
    End If
    
    Call validateDetailData(ActiveSheet, rowNum)
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列
            csvContent = csvContent & CleanCSVField(ws.Cells(r, 3).Value)
            ' CSV col2-11 -> G-P列
            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