diff --git a/src/data/区間詳細.csv b/src/data/区間詳細.csv new file mode 100644 index 0000000..1bbb2a5 --- /dev/null +++ b/src/data/区間詳細.csv @@ -0,0 +1,20 @@ +pԃR[h,,R[h,,1ӌ^/̔z,z/P(z)/pz,x/P()/ʗ,ʗ/Q(z),Q(),[(z),ʗ +00001,1,003,Uӌ,7920,47520,6,,,, +00001,2,001,eXg,15000,0,0,0,0,0, +00001,3,001,vyChJ[h,20000,20000,,,,, +00002,1,003,Uӌ,1451.833,8711,6,,,, +00002,2,001,eXg,15000,0,0,0,0,0, +00002,3,002,0002eXg,45000,60000,,,,, +00003,2,002,eXg2,500,500,10,500,10,0, +00004,3,003,0004eXg,5000,5000,,,,, +00005,1,003,Uӌ,4753.333,28520,6,,,, +00006,1,001,Pӌ,7920,7920,1,,,, +00006,1,003,Uӌ,7920,47520,6,,,, +00021,1,001,Pӌ,6260,6260,1,,,, +00038,1,001,Pӌ,6260,6260,1,,,, +00056,1,003,Uӌ,10030,10030,1,,,, +00067,1,003,Uӌ,4486.666,26920,6,,,, +00068,1,003,Uӌ,52800,316800,6,,,, +00069,1,006,Uӌ,7181.666,43090,6,,,, +00070,1,003,Uӌ,6426.666,38560,6,,,, +00071,1,003,Uӌ,6879,6879,1,,,, \ No newline at end of file diff --git a/src/module/Module_Common.bas b/src/module/Module_Common.bas index 5f07a36..68d3ba1 100644 --- a/src/module/Module_Common.bas +++ b/src/module/Module_Common.bas @@ -2,6 +2,25 @@ ' Common Functions ' ============================================================ +' Get CSV header from specified row and columns +Function GetCSVHeader(ByVal ws As Worksheet, ByVal colLetters As Variant, ByVal headerRow As Long) As Variant + Dim colCount As Long: colCount = UBound(colLetters) - LBound(colLetters) + 1 + Dim headerArr() As String + ReDim headerArr(1 To 1, 1 To colCount) + + Dim i As Long + Dim cellValue As String + For i = 0 To colCount - 1 + cellValue = Trim(ws.Cells(headerRow, Columns(colLetters(i)).Column).Value) + cellValue = Replace(cellValue, vbLf, "") + cellValue = Replace(cellValue, vbCr, "") + cellValue = Replace(cellValue, vbCrLf, "") + headerArr(1, i + 1) = cellValue + Next i + + GetCSVHeader = headerArr +End Function + Function CleanCSVField(ByVal inputStr As String) As String Dim s As String s = Trim(inputStr) @@ -145,7 +164,9 @@ Function ClearDataRows(ByVal ws As Worksheet, ByVal startCol As Long, ByVal endC Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws, startCol, endCol, startRow) If lastDataRow >= startRow Then - ws.Range(ws.Cells(startRow, startCol), ws.Cells(lastDataRow, endCol)).ClearContents + Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(startRow, startCol), ws.Cells(lastDataRow, endCol)) + clearRange.ClearContents + clearRange.Interior.Color = vbWhite End If End Function diff --git a/src/module/Read_Common.bas b/src/module/Read_Common.bas index 986923f..1e66ff6 100644 --- a/src/module/Read_Common.bas +++ b/src/module/Read_Common.bas @@ -49,7 +49,7 @@ Function ReadCSVAs2DArrayStrict( _ .Close End With - ' === stardand === + ' === standardize === textContent = Replace(textContent, vbCrLf, vbLf) textContent = Replace(textContent, vbCr, vbLf) @@ -135,6 +135,10 @@ Private Function ParseCSVLines(ByVal csvText As String) As Collection currentField = currentField & c i = i + 1 Else + ' Clean field before adding + currentField = Trim(currentField) + currentField = Replace(currentField, vbCr, "") + currentField = Replace(currentField, vbLf, "") currentRow.Add currentField currentField = "" i = i + 1 @@ -167,6 +171,10 @@ Private Function ParseCSVLines(ByVal csvText As String) As Collection ' Handle last row without trailing newline If currentField <> "" Or currentRow.Count > 0 Then + ' Clean field before adding + currentField = Trim(currentField) + currentField = Replace(currentField, vbCr, "") + currentField = Replace(currentField, vbLf, "") currentRow.Add currentField Dim lastArr() As String If currentRow.Count > 0 Then diff --git a/src/thisWorkbook/Master_M1_Kukan.bas b/src/thisWorkbook/Master_M1_Kukan.bas index ef63b38..15f1e33 100644 --- a/src/thisWorkbook/Master_M1_Kukan.bas +++ b/src/thisWorkbook/Master_M1_Kukan.bas @@ -1,13 +1,16 @@ -' ====== (222) ======= - ' ====== Constants ====== -Const START_COL As Long = 3 ' C column -Const END_COL As Long = 14 ' N column -Const ERROR_COL As Long = 15 ' O column +Const START_COL As Long = 3 ' C column +Const END_COL As Long = 14 ' N column +Const ERROR_COL As Long = 15 ' O column +Const M1_HEADER_ROW As Long = 5 Private z1Cache As Object ' Z1 cache Private enumCache As Object ' Z1 cache +Function HEADERS() As Variant + HEADERS = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N") +End Function + ' ====== Function ====== Public Sub RefreshZ1Cache() On Error GoTo RefreshError @@ -67,23 +70,6 @@ Private Sub CreateEnumDropdown(ByVal rowNum As Long) End Sub -' Get CSV header from row 5 (columns C to N) -Function GetM1CSVHeader(ByVal ws As Worksheet) As Variant - Dim headerArr(1 To 1, 1 To 12) As String - Dim i As Long - Dim cellValue As String - - For i = 1 To 12 - cellValue = Trim(ws.Cells(5, i + 2).Value) ' i+2: 1→3(C), 12→14(N) - ' Remove line breaks - cellValue = Replace(cellValue, vbLf, "") - cellValue = Replace(cellValue, vbCr, "") - cellValue = Replace(cellValue, vbCrLf, "") - headerArr(1, i) = cellValue - Next i - - GetM1CSVHeader = headerArr -End Function Private Sub Worksheet_Change(ByVal Target As Range) ' === Column C changes: Create L column dropdown === @@ -121,11 +107,8 @@ Private Sub Worksheet_Change(ByVal Target As Range) End Sub Sub M1_Import() - Dim wsTarget As Worksheet: Set wsTarget = Me - ' === Step 1: Select CSV file === - Dim filePath As String - filePath = SelectCSVFile() + Dim filePath As String: filePath = SelectCSVFile() If filePath = "" Then Exit Sub ' === Step 2: Read CSV with Shift-JIS (using common function) === @@ -137,19 +120,22 @@ Sub M1_Import() MsgBox "No data in CSV.", vbExclamation Exit Sub End If + ' === Step 3:Clear all data rows before import === Application.EnableEvents = False + Dim wsTarget As Worksheet: Set wsTarget = Me Call ClearDataRows(wsTarget, START_COL, END_COL, 7) Application.EnableEvents = True - ' === Step 3: Write CSV data to worksheet (forward order) === - Dim i As Long + ' === Step 4: Write CSV data to worksheet === + Dim colLetters As Variant: colLetters = HEADERS() Dim writeRow As Long: writeRow = 7 + Dim i As Long For i = LBound(csvData, 1) To UBound(csvData, 1) ' CSV col 1-12 -> C-N column Dim j As Long - For j = 1 To 12 - wsTarget.Cells(writeRow, j + 2).Value = CleanCSVField(CStr(csvData(i, j))) + For j = 0 To 11 + wsTarget.Cells(writeRow, Columns(colLetters(j)).Column).Value = CleanCSVField(CStr(csvData(i, j + 1))) Next j writeRow = writeRow + 1 Next i @@ -268,10 +254,8 @@ Sub M1_Export() Exit Sub End If - Dim ws As Worksheet - Set ws = Me - ' === Step 1: Validate all rows before export === + Dim ws As Worksheet: Set ws = Me Dim r As Long, errorCount As Long For r = 7 To lastDataRow Call validate(r, lastDataRow) @@ -286,8 +270,7 @@ Sub M1_Export() End If ' === Step 2: Select save path === - Dim savePath As String - savePath = GetSaveCSVPath() + Dim savePath As String: savePath = GetSaveCSVPath() If savePath = "" Then Exit Sub ' === Step 3: Count data rows === @@ -295,22 +278,23 @@ Sub M1_Export() ' === Step 4: Build array with header and data === Dim headerArr As Variant - headerArr = GetM1CSVHeader(ws) + Dim colLetters As Variant: colLetters = HEADERS() + headerArr = GetCSVHeader(ws, colLetters, M1_HEADER_ROW) Dim outputArr As Variant ReDim outputArr(1 To rowCount + 1, 1 To 12) ' Row 1: header Dim colIdx As Long - For colIdx = 1 To 12 - outputArr(1, colIdx) = headerArr(1, colIdx) + For colIdx = 0 To 11 + outputArr(1, colIdx + 1) = headerArr(1, colIdx + 1) Next colIdx ' Rows 2+: data (C-N columns) Dim dataRow As Long: dataRow = 2 For r = 7 To lastDataRow - For colIdx = 1 To 12 - outputArr(dataRow, colIdx) = CleanCSVField(ws.Cells(r, colIdx + 2).Value) + For colIdx = 0 To 11 + outputArr(dataRow, colIdx + 1) = CleanCSVField(ws.Cells(r, Columns(colLetters(colIdx)).Column).Value) Next colIdx dataRow = dataRow + 1 Next r diff --git a/src/thisWorkbook/Master_M2_Kukan_detail.bas b/src/thisWorkbook/Master_M2_Kukan_detail.bas index ebf12b7..d499519 100644 --- a/src/thisWorkbook/Master_M2_Kukan_detail.bas +++ b/src/thisWorkbook/Master_M2_Kukan_detail.bas @@ -1,5 +1,30 @@ -' CSV Header Constants -Const CSV_HEADER As String = "利用区間コード,券種,コード,名称,1箇月運賃/販売額,定期額/券１(額)/利用額,定期支給期間/券１(枚)/特別料金,特別料金/券２(額),券２(枚),端数(額),特別料金" +' ====== Constants ====== +Const START_COL As Long = 3 ' C column +Const END_COL As Long = 18 ' R column +Const ERROR_COL As Long = 19 ' S column +Const M2_HEADER_ROW As Long = 6 + +Private m1Cache As Object ' M1 cache + +Function HEADERS() As Variant + HEADERS = Array("C", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R") +End Function + +' ====== Function ====== +Public Sub RefreshM1Cache() + On Error GoTo RefreshError + Set m1Cache = LoadLookup("M1", keyCol:=3, valueCols:=Array(4), startRow:=7) + On Error GoTo 0 + + If m1Cache Is Nothing Or m1Cache.Count = 0 Then + Err.Raise 1001, "RefreshM1Cache", "M1 reference data is empty" + End If + + Exit Sub + +RefreshError: + Err.Raise 1002, "RefreshM1Cache", "Failed to load M1 lookup cache: " & Err.Description +End Sub Private Sub Worksheet_Change(ByVal Target As Range) ' === Fill D, E when C column changes === @@ -9,13 +34,13 @@ Private Sub Worksheet_Change(ByVal Target As Range) If Trim(cell.Value) = "" Then Call ClearRowData(Me, cell.Row) Else - Call FillFromKukanMaster(Me, cell.Row) + Call FillFromM1(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) +Sub FillFromM1(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 @@ -54,310 +79,190 @@ Sub ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long) 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 - +Sub M2_Import() ' === 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 + Dim filePath As String: filePath = SelectCSVFile() + If filePath = "" Then Exit Sub + + ' === Step 2: Read CSV with Shift-JIS (using common function) === + On Error GoTo ImportError + Dim csvData As Variant: csvData = ReadCSVAs2DArrayStrict(filePath, 11, "shift_jis", True) + On Error GoTo 0 + + If UBound(csvData, 1) < 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 + ' === Step 3:Clear all data rows before import === + Application.EnableEvents = False + Dim wsTarget As Worksheet: Set wsTarget = Me + Call ClearDataRows(wsTarget, START_COL, ERROR_COL, 7) + Application.EnableEvents = True - + ' === Step 4: Write CSV data to worksheet === + Dim colLetters As Variant: colLetters = HEADERS() + Dim writeRow As Long: writeRow = 7 + Dim i As Long + For i = LBound(csvData, 1) To UBound(csvData, 1) + ' CSV col 1-11 -> C, I-R column + Dim j As Long + For j = 0 To 10 + wsTarget.Cells(writeRow, Columns(colLetters(j)).Column).Value = CleanCSVField(CStr(csvData(i, j + 1))) + Next j writeRow = writeRow + 1 -NextLine: Next i - + MsgBox writeRow - 7 & " rows imported.", vbInformation + Exit Sub + +ImportError: + MsgBox "CSV import failed: " & Err.Description, vbExclamation 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 validate(ByVal rowNum As Long, ByVal lastDataRow As Long) + Set ws = Me -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" + Dim clearRange As Range + Set clearRange = ws.Range(ws.Cells(rowNum, START_COL), ws.Cells(rowNum, END_COL)) + clearRange.Interior.Color = vbWhite + + ' Check column required + Dim colLetter As Variant + For Each colLetter In Array("C", "I", "J", "K") + If Trim(ws.Range(colLetter & rowNum).Value) = "" Then + ws.Cells(rowNum, ERROR_COL).Value = colLetter & " column is required" + ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0) + Exit Sub + End If + Next colLetter + + ' Check column numeric (only if has value) + Dim numericCols As Variant: numericCols = Array("L", "M", "N", "O", "P", "Q", "R") + Dim col As Variant + For Each col In numericCols + Dim val As String: val = Trim(ws.Range(col & rowNum).Value & "") + If val <> "" And Not IsNumeric(val) Then + ws.Cells(rowNum, ERROR_COL).Value = col & " column must be numeric" + ws.Range(col & rowNum).Interior.Color = RGB(255, 0, 0) 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 + + ' Check C column in the cache + If m1Cache Is Nothing Then Call RefreshM1Cache + Dim dValue As String: dValue = Trim(ws.Range("C" & rowNum).Value) + + If Not m1Cache.Exists(dValue) Then + ws.Cells(rowNum, ERROR_COL).Value = "C column does not exist in M1." + ws.Range("C" & rowNum).Interior.Color = RGB(255, 0, 0) + Exit Sub + End If + + ' Check I column in the kenshuKbn + Dim kenshuKbn As Variant: kenshuKbn = Array("1", "2", "3") + Dim iValue As String: iValue = Trim(ws.Range("I" & rowNum).Value) + If UBound(Filter(kenshuKbn, iValue)) = -1 Then + ws.Cells(rowNum, ERROR_COL).Value = "I column (kenshuKbn) must be 1, 2, or 3" + ws.Range("I" & rowNum).Interior.Color = RGB(255, 0, 0) + Exit Sub + End If + 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 +Sub M2_validateButton() + Dim lastDataRow As Long, r As Long, errorCount As Long + lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL) + + If lastDataRow < 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 + + For r = 7 To lastDataRow + Validate r, lastDataRow + If Trim(Cells(r, ERROR_COL).Value) <> "" Then errorCount = errorCount + 1 End If Next r - - MsgBox "Validation complete. Errors: " & errorCount & ", ", vbInformation + + 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 - +Sub M2_Export() + Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL) 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 + + ' === Step 1: Validate all rows before export === + Dim ws As Worksheet: Set ws = Me + Dim r As Long, errorCount 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 + Call validate(r, lastDataRow) + If Trim(ws.Cells(r, ERROR_COL).Value) <> "" Then + errorCount = errorCount + 1 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 - + + If errorCount > 0 Then + MsgBox "Validation failed. Found " & errorCount & " error(s). Please correct them before exporting.", vbCritical + Exit Sub + End If + + ' === Step 2: Select save path === + Dim savePath As String: savePath = GetSaveCSVPath() + If savePath = "" Then Exit Sub + + ' === Step 3: Count data rows === + Dim rowCount As Long: rowCount = lastDataRow - 6 + + ' === Step 4: Build array with header and data === + Dim headerArr As Variant + Dim colLetters As Variant: colLetters = HEADERS() + headerArr = GetCSVHeader(ws, colLetters, M2_HEADER_ROW) + + Dim outputArr As Variant + ReDim outputArr(1 To rowCount + 1, 1 To 11) + + ' Row 1: header + Dim colIdx As Long + For colIdx = 0 To 10 + outputArr(1, colIdx + 1) = headerArr(1, colIdx + 1) + Next colIdx + + ' Rows 2+: data (C, I-R columns) + Dim dataRow As Long: dataRow = 2 + For r = 7 To lastDataRow + For colIdx = 0 To 10 + outputArr(dataRow, colIdx + 1) = CleanCSVField(ws.Cells(r, Columns(colLetters(colIdx)).Column).Value) + Next colIdx + dataRow = dataRow + 1 + Next r + + On Error GoTo ExportError + Call WriteCSVFromArray(savePath, outputArr, "shift_jis", False) + On Error GoTo 0 + MsgBox "CSV export completed. Total data rows: " & rowCount, vbInformation + Exit Sub + +ExportError: + MsgBox "CSV export failed: " & Err.Description, vbExclamation + +End Sub + +Sub M2_SortDataRowsByC() + Call SortDataRows(3) +End Sub + +Sub M2_ToggleAutoFilter() + Call ToggleAutoFilter(START_COL, END_COL) +End Sub + +Sub M2_AutoFitColumnWidth() + Call AutoFitColumnWidth(START_COL, END_COL) End Sub \ No newline at end of file diff --git a/通勤手当テンプレート_案.xlsm b/通勤手当テンプレート_案.xlsm index 49bbad1..08ad222 100644 Binary files a/通勤手当テンプレート_案.xlsm and b/通勤手当テンプレート_案.xlsm differ