Add vba_code_kotsu_master for Z1 sheet

vba_code_kotsu_master.txt

@@ -0,0 +1,363 @@
+' 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("Z1")
+    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, 6).Validation.Delete
+    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, 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
+    
+    ' 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

vba_code_kukan_detail_master.txt

@@ -50,6 +50,7 @@ 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, 19).ClearContents ' Q column error info
 End Sub
 
@@ -285,7 +286,7 @@ Sub validateDetailDataButton()
     errorCount = 0
     For r = 7 To lastRow
         Call validateDetailData(ws, r)
-        If Trim(ws.Cells(r, 19).Value) <> "" Then
+        If Trim(ws.Cells(r, 17).Value) <> "" Then
             errorCount = errorCount + 1
         End If
     Next r