diff --git a/vba_code_kotsu_master.bas b/vba_code_kotsu_master.bas index 1fffbf4..f643221 100644 --- a/vba_code_kotsu_master.bas +++ b/vba_code_kotsu_master.bas @@ -53,10 +53,11 @@ Sub Z1_ExportMasterDetailData() Dim ws As Worksheet Dim lastDataRow As Long Dim savePath As String - Dim csvContent As String Dim r As Long - Dim j As Long Dim rowCount As Long + Dim dataArray() As Variant + Dim dataIdx As Long + Dim j As Long Set ws = ActiveSheet @@ -70,28 +71,36 @@ Sub Z1_ExportMasterDetailData() savePath = GetSaveCSVPath() If savePath = "" Then Exit Sub - ' Build data rows (no header) - CSV 1-7 = C-I + ' Count valid rows first (C column non-empty from row 7 onward) rowCount = 0 For r = 7 To lastDataRow If Len(Trim(ws.Cells(r, 3).Value & "")) > 0 Then rowCount = rowCount + 1 - For j = 3 To 9 - If j = 3 Then - csvContent = csvContent & CleanCSVField(ws.Cells(r, j).Value) - Else - csvContent = csvContent & "," & CleanCSVField(ws.Cells(r, j).Value) - End If - Next j - csvContent = csvContent & vbLf End If Next r - ' Trim trailing - Do While Right(csvContent, 1) = vbLf - csvContent = Left(csvContent, Len(csvContent) - 1) - Loop + ' If no data, exit + If rowCount = 0 Then + MsgBox "No data rows to output.", vbExclamation + Exit Sub + End If - Call WriteCSVFile(savePath, csvContent) + ' Initialize 2D array: (1 To rowCount, 1 To 7) for columns C-I (3 to 9) + ReDim dataArray(1 To rowCount, 1 To 7) + + ' Fill the array + dataIdx = 0 + For r = 7 To lastDataRow + If Len(Trim(ws.Cells(r, 3).Value & "")) > 0 Then + dataIdx = dataIdx + 1 + For j = 3 To 9 + dataArray(dataIdx, j - 2) = ws.Cells(r, j).Value ' C->1, D->2, ..., I->7 + Next j + End If + Next r + + ' Write using the new array-based CSV writer + Call WriteCSVFromArray(savePath, dataArray, "utf-8", True) MsgBox "CSV export completed. Total data rows: " & rowCount, vbInformation End Sub diff --git a/vba_code_write_csv_common.bas b/vba_code_write_csv_common.bas new file mode 100644 index 0000000..3b7bad8 --- /dev/null +++ b/vba_code_write_csv_common.bas @@ -0,0 +1,119 @@ +' Writes a 2D array to a CSV file +Sub WriteCSVFromArray( _ + ByVal filePath As String, _ + ByVal data As Variant, _ + Optional ByVal Charset As String = "shift_jis", _ + Optional ByVal alwaysQuote As Boolean = False _ +) + ' === Input validation === + If Not IsArray(data) Then + Err.Raise 513, , "Input 'data' must be an array." + End If + + Dim numDims As Long + On Error Resume Next + numDims = ArrayDimensions(data) + On Error GoTo 0 + If numDims <> 2 Then + Err.Raise 514, , "Input array must be 2-dimensional." + End If + + Dim rows As Long, cols As Long + rows = UBound(data, 1) - LBound(data, 1) + 1 + cols = UBound(data, 2) - LBound(data, 2) + 1 + + If rows = 0 Or cols = 0 Then Exit Sub ' Empty array, exit early + + ' === Build CSV content === + Dim outputLines As Collection + Set outputLines = New Collection + + Dim i As Long, j As Long + Dim rowStr As String + Dim field As String + Dim needsQuote As Boolean + + For i = LBound(data, 1) To UBound(data, 1) + Dim fields As Variant + ReDim fields(1 To cols) + + For j = LBound(data, 2) To UBound(data, 2) + ' Safely convert variant to string + field = SafeToString(data(i, j)) + + ' Determine if the field needs quoting (per RFC 4180) + needsQuote = alwaysQuote Or (InStr(field, """") > 0) Or _ + (InStr(field, ",") > 0) Or _ + (InStr(field, vbLf) > 0) Or _ + (InStr(field, vbCrLf) > 0) Or _ + (InStr(field, vbCr) > 0) Or _ + (Left(field, 1) = " " Or Right(field, 1) = " ") + + If needsQuote Then + ' Escape double quotes: "" represents a single " + field = """" & Replace(field, """", """""") & """" + End If + + fields(j - LBound(data, 2) + 1) = field + Next j + + rowStr = Join(fields, ",") + outputLines.Add rowStr + Next i + + ' Concatenate all lines + Dim finalContent As String + finalContent = Join(CollectionToArray(outputLines), vbCrLf) + + ' === Write to file === + Dim stream As Object + Set stream = CreateObject("ADODB.Stream") + With stream + .Type = 2 ' adTypeText + .Charset = Charset + .Open + .WriteText finalContent, 0 ' adWriteChar + .SaveToFile filePath, 2 ' adSaveCreateOverWrite + .Close + End With +End Sub + +' Helper function: safely convert any Variant to a string +Private Function SafeToString(ByVal v As Variant) As String + On Error Resume Next + If IsNull(v) Or IsEmpty(v) Then + SafeToString = "" + Else + SafeToString = CStr(v) + End If + On Error GoTo 0 +End Function + +' Helper function: get the number of dimensions of an array (1, 2, ...) +Private Function ArrayDimensions(arr As Variant) As Long + Dim dimCount As Long + On Error GoTo ExitPoint + Do + dimCount = dimCount + 1 + Dim tmp As Long + tmp = UBound(arr, dimCount) + Loop +ExitPoint: + ArrayDimensions = dimCount - 1 +End Function + +' Helper function: convert a Collection to a 1D array (for use with Join) +Private Function CollectionToArray(col As Collection) As Variant + If col.Count = 0 Then + CollectionToArray = Array() + Exit Function + End If + + Dim arr() As String + ReDim arr(1 To col.Count) + Dim i As Long + For i = 1 To col.Count + arr(i) = col(i) + Next i + CollectionToArray = arr +End Function \ No newline at end of file diff --git a/通勤手当テンプレート_案.xlsm b/通勤手当テンプレート_案.xlsm index 2a30b65..e6507ef 100644 Binary files a/通勤手当テンプレート_案.xlsm and b/通勤手当テンプレート_案.xlsm differ