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箇月運賃/販売額,定期額/券1(額)/利用額,定期支給期間/券1(枚)/特別料金,特別料金/券2(額),券2(枚),端数(額),特別料金 Dim headerList As Variant headerList = Array("利用区間コード", "券種", "コード", "名称", "1箇月運賃/販売額", "定期額/券1(額)/利用額", "定期支給期間/券1(枚)/特別料金", "特別料金/券2(額)", "券2(枚)", "端数(額)", "特別料金") ' 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