diff --git a/vba_code_common.bas b/vba_code_common.bas index f48cea8..4243675 100644 --- a/vba_code_common.bas +++ b/vba_code_common.bas @@ -2,49 +2,20 @@ ' Common Functions ' ============================================================ -Function CleanCSVField(ByVal field As Variant) As String - If IsEmpty(field) Or IsNull(field) Then - CleanCSVField = "" - Exit Function - End If +Function CleanCSVField(ByVal inputStr As String) As String + Dim s As String + s = Trim(inputStr) - 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 - -Function ValidateCSVColumnCount(ByVal lines As Variant, ByVal expectedColumns As Long) As Boolean - ValidateCSVColumnCount = True - - Dim lineNum As Long - Dim dataArray As Variant - Dim validRowCount As Long - validRowCount = 0 - - For lineNum = 0 To UBound(lines) - If Trim(lines(lineNum)) <> "" Then - dataArray = Split(lines(lineNum), ",") - If UBound(dataArray) + 1 <> expectedColumns Then - MsgBox "CSV line " & (lineNum + 1) & " has " & (UBound(dataArray) + 1) & " columns. Expected " & expectedColumns & ".", vbExclamation - ValidateCSVColumnCount = False + ' calcute + If Len(s) > 0 Then + Select Case Left(s, 1) + Case "=", "+", "-", "@" + CleanCSVField = "'" & s Exit Function - End If - validRowCount = validRowCount + 1 - End If - Next lineNum - - If validRowCount = 0 Then - MsgBox "No valid data in CSV.", vbExclamation - ValidateCSVColumnCount = False + End Select End If + + CleanCSVField = s End Function Function GetLastDataRow(ByVal ws As Worksheet, ByVal columnNum As Long) As Long @@ -109,141 +80,101 @@ Sub WriteCSVFile(ByVal filePath As String, ByVal content As String) End With End Sub - -Function ReadCSVFile(ByVal filePath As String, Optional ByVal charset As String = "shift_jis") As Variant - If filePath = "" Then - ReadCSVFile = Array() - Exit Function - End If - - Dim stream As Object - Dim textContent As String - - Set stream = CreateObject("ADODB.Stream") - With stream - .Type = 2 - .Charset = charset - .Open - .LoadFromFile filePath - textContent = .ReadText - .Close - End With - - ReadCSVFile = Split(textContent, vbLf) -End Function - ' Read a CSV file and return its content as a strict 2D array (1-based). -' The function ensures all rows have the same number of columns as the first row. -' If any row has a different column count, an error is raised immediately. +' All rows must have the same number of columns as the first row. +' If the file is empty and defaultColumnCount > 0, returns an empty 2D array with zero rows and defaultColumnCount columns. ' Parameters: -' filePath: Full path to the CSV file. -' charset: Text encoding (e.g., "cp932" for Shift-JIS, "utf-8" for UTF-8). -Function ReadCSVAs2DArrayStrict(ByVal filePath As String, Optional ByVal charset As String = "cp932") As Variant - ' Check if file exists - If filePath = "" Or Dir(filePath) = "" Then - Err.Raise vbObjectError + 1001, , "File not found: " & filePath +' filePath: Full path to the CSV file. +' charset: Text encoding (e.g., "cp932", "utf-8"). +' defaultColumnCount: Optional. Used only if CSV has no rows. Must be >= 0. +Function ReadCSVAs2DArrayStrict( _ + ByVal filePath As String, _ + ByVal expectedColumnCount As Long, _ + Optional ByVal charset As String = "cp932", _ + Optional ByVal hasHeader As Boolean = False) As Variant + + ' === validate expectedColumnCount === + If expectedColumnCount <= 0 Then + Err.Raise 5001, , "expectedColumnCount must be >= 1." End If - ' Read entire file using ADODB.Stream with specified character set + If Dir(filePath) = "" Then + Err.Raise 5002, , "File not found: " & filePath + End If + + ' === read csv file === Dim stream As Object Set stream = CreateObject("ADODB.Stream") With stream .Type = 2 ' adTypeText - .Charset = charset + .charset = charset .Open .LoadFromFile filePath Dim textContent As String textContent = .ReadText .Close End With - - ' Handle empty file - If textContent = "" Then - Err.Raise vbObjectError + 1002, , "CSV file is empty" - End If - - ' Normalize line breaks to vbLf (\n) + + ' === stardand === textContent = Replace(textContent, vbCrLf, vbLf) textContent = Replace(textContent, vbCr, vbLf) - - ' Parse CSV lines into a collection of string arrays + + ' === transfer into collection === Dim lines As Collection Set lines = ParseCSVLines(textContent) - + + ' === validate empty === If lines.Count = 0 Then - Err.Raise vbObjectError + 1003, , "No valid rows parsed from CSV" + Err.Raise 5003, , "CSV file is empty." End If - - ' Determine expected column count from the first row - Dim expectedCols As Long - Dim firstRow As Variant - firstRow = lines(1) - expectedCols = UBound(firstRow) - LBound(firstRow) + 1 - - If expectedCols <= 0 Then - Err.Raise vbObjectError + 1004, , "First row contains no fields" - End If - - ' Validate every row has exactly expectedCols columns + + ' === loop the row, validate column count === Dim i As Long For i = 1 To lines.Count - Dim currentRow As Variant - currentRow = lines(i) + Dim rowArr As Variant + rowArr = lines(i) Dim actualCols As Long - actualCols = UBound(currentRow) - LBound(currentRow) + 1 + actualCols = UBound(rowArr) - LBound(rowArr) + 1 - If actualCols <> expectedCols Then - Err.Raise vbObjectError + 1005, , _ - "CSV row column count mismatch!" & vbCrLf & _ - "Expected columns: " & expectedCols & vbCrLf & _ - "Row " & i & " has " & actualCols & " columns." + If actualCols <> expectedColumnCount Then + Err.Raise 5004, , "Row " & i & ": Expected " & expectedColumnCount & " columns, got " & actualCols & "." End If Next i - - ' Build 1-based 2D result array (no padding needed due to strict validation) + Dim result As Variant - ReDim result(1 To lines.Count, 1 To expectedCols) + ReDim result(1 To lines.Count, 1 To expectedColumnCount) For i = 1 To lines.Count - currentRow = lines(i) + rowArr = lines(i) Dim j As Long - For j = LBound(currentRow) To UBound(currentRow) - result(i, j - LBound(currentRow) + 1) = currentRow(j) + For j = LBound(rowArr) To UBound(rowArr) + result(i, j - LBound(rowArr) + 1) = rowArr(j) Next j Next i - + ReadCSVAs2DArrayStrict = result End Function -' Parse CSV text into a Collection of string arrays, respecting RFC 4180 rules. -' Handles quoted fields, commas/line breaks inside quotes, and escaped quotes (""). -' Input: CSV text with normalized line endings (vbLf only). -' Output: Collection where each item is a zero-based array of field strings. +' Helper function: Parse CSV text into collection of string arrays (zero-based per row) Private Function ParseCSVLines(ByVal csvText As String) As Collection Set ParseCSVLines = New Collection - - Dim length As Long - length = Len(csvText) + Dim length As Long: length = Len(csvText) If length = 0 Then Exit Function - Dim i As Long - i = 1 + Dim i As Long: i = 1 Dim currentField As String - Dim currentRow As Collection - Set currentRow = New Collection + Dim currentRow As Collection: Set currentRow = New Collection Dim inQuotes As Boolean Dim c As String Do While i <= length c = Mid$(csvText, i, 1) - Select Case c Case """" If inQuotes Then - ' Check for escaped quote ("") If i < length And Mid$(csvText, i + 1, 1) = """" Then currentField = currentField & """" - i = i + 2 ' Skip both quotes + i = i + 2 Else inQuotes = False i = i + 1 @@ -252,26 +183,21 @@ Private Function ParseCSVLines(ByVal csvText As String) As Collection inQuotes = True i = i + 1 End If - Case "," If inQuotes Then currentField = currentField & c i = i + 1 Else - ' End of field currentRow.Add currentField currentField = "" i = i + 1 End If - Case vbLf If inQuotes Then currentField = currentField & c i = i + 1 Else - ' End of row currentRow.Add currentField - ' Convert collection to array Dim arr() As String If currentRow.Count > 0 Then ReDim arr(0 To currentRow.Count - 1) @@ -281,20 +207,18 @@ Private Function ParseCSVLines(ByVal csvText As String) As Collection Next k End If ParseCSVLines.Add arr - ' Reset for next row Set currentRow = New Collection currentField = "" inQuotes = False i = i + 1 End If - Case Else currentField = currentField & c i = i + 1 End Select Loop - ' Handle last row if file doesn't end with newline + ' Handle last row without trailing newline If currentField <> "" Or currentRow.Count > 0 Then currentRow.Add currentField Dim lastArr() As String diff --git a/vba_code_kotsu_master.bas b/vba_code_kotsu_master.bas index 337a2d3..1fffbf4 100644 --- a/vba_code_kotsu_master.bas +++ b/vba_code_kotsu_master.bas @@ -13,40 +13,40 @@ Sub Z1_ImportMasterDetailData() Dim writeRow As Long Set wsTarget = Me + On Error GoTo ErrorHandler ' Step 1: Select CSV file filePath = SelectCSVFile() If filePath = "" Then Exit Sub - ' Step 2: Read CSV - lines = ReadCSVFile(filePath, "utf-8") + ' Step 2: Read CSV and return 2D array + lines = ReadCSVAs2DArrayStrict(filePath, 7, "utf-8") - ' Step 3: Validate column count - If Not ValidateCSVColumnCount(lines, 7) Then Exit Sub - - ' Step 4: Clear data rows + ' Step 3: Clear data rows Call ClearDataRows(wsTarget, 7, 3) - ' Step 5: Import data + ' Step 4: Import data writeRow = 7 - - For i = 0 To UBound(lines) - If Trim(lines(i)) <> "" Then - dataArray = Split(lines(i), ",") - - wsTarget.Cells(writeRow, 3).Value = CleanCSVField(CStr(dataArray(0))) - wsTarget.Cells(writeRow, 4).Value = CleanCSVField(CStr(dataArray(1))) - wsTarget.Cells(writeRow, 5).Value = CleanCSVField(CStr(dataArray(2))) - wsTarget.Cells(writeRow, 6).Value = CleanCSVField(CStr(dataArray(3))) - wsTarget.Cells(writeRow, 7).Value = CleanCSVField(CStr(dataArray(4))) - wsTarget.Cells(writeRow, 8).Value = CleanCSVField(CStr(dataArray(5))) - wsTarget.Cells(writeRow, 9).Value = CleanCSVField(CStr(dataArray(6))) + For i = LBound(lines, 1) To UBound(lines, 1) + If Not isRowEmpty Then + wsTarget.Cells(writeRow, 3).Value = CleanCSVField(CStr(lines(i, 1))) + wsTarget.Cells(writeRow, 4).Value = CleanCSVField(CStr(lines(i, 2))) + wsTarget.Cells(writeRow, 5).Value = CleanCSVField(CStr(lines(i, 3))) + wsTarget.Cells(writeRow, 6).Value = CleanCSVField(CStr(lines(i, 4))) + wsTarget.Cells(writeRow, 7).Value = CleanCSVField(CStr(lines(i, 5))) + wsTarget.Cells(writeRow, 8).Value = CleanCSVField(CStr(lines(i, 6))) + wsTarget.Cells(writeRow, 9).Value = CleanCSVField(CStr(lines(i, 7))) writeRow = writeRow + 1 End If Next i MsgBox writeRow - 7 & " rows imported.", vbInformation + + Exit Sub + +ErrorHandler: + MsgBox "Import fails:" & vbCrLf & Err.Description, vbCritical End Sub Sub Z1_ExportMasterDetailData() diff --git a/通勤手当テンプレート_案.xlsm b/通勤手当テンプレート_案.xlsm index 434a5a7..2a30b65 100644 Binary files a/通勤手当テンプレート_案.xlsm and b/通勤手当テンプレート_案.xlsm differ