diff --git a/vba_code_kotsu_master.txt b/vba_code_kotsu_master.txt new file mode 100644 index 0000000..b299526 --- /dev/null +++ b/vba_code_kotsu_master.txt @@ -0,0 +1,363 @@ +' CSV Header Constants +Const CSV_HEADER As String = "利用区間コード,券種,コード,名称,1箇月運賃/販売額,定期額/券1(額)/利用額,定期支給期間/券1(枚)/特別料金,特別料金/券2(額),券2(枚),端数(額),特別料金" + +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 \ No newline at end of file diff --git a/vba_code_kukan_detail_master.txt b/vba_code_kukan_detail_master.txt index 6bda727..ebf12b7 100644 --- a/vba_code_kukan_detail_master.txt +++ b/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