diff --git a/src/module/Module_Common.bas b/src/module/Module_Common.bas index 223f258..8bf0f9b 100644 --- a/src/module/Module_Common.bas +++ b/src/module/Module_Common.bas @@ -1,92 +1,92 @@ -' ============================================================ -' Common Functions -' ============================================================ - -Function CleanCSVField(ByVal inputStr As String) As String - Dim s As String - s = Trim(inputStr) - - ' calcute - If Len(s) > 0 Then - Select Case Left(s, 1) - Case "=", "+", "-", "@" - CleanCSVField = "'" & s - Exit Function - End Select - End If - - CleanCSVField = s -End Function - -Function GetLastDataRow(ByVal ws As Worksheet, ByVal columnNum As Long) As Long - GetLastDataRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row -End Function - -Sub ClearDataRows(ByVal ws As Worksheet, ByVal startRow As Long, ByVal columnNum As Long) - Dim lastRow As Long - lastRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row - - If lastRow >= startRow Then - ws.Range(ws.Cells(startRow, 1), ws.Cells(lastRow, 20)).ClearContents - End If -End Sub - -Sub SortDataRows(Optional ByVal sortColumn As Long = 3) - Dim ws As Worksheet - Dim lastRow As Long - Dim startRow As Long - Dim sortOrder As Long - - Set ws = ActiveSheet - startRow = 7 - lastRow = GetLastDataRow(ws, sortColumn) - - If lastRow < startRow Then - MsgBox "No data to sort.", vbExclamation - Exit Sub - End If - - ' Determine sort order based on first row's current state - Dim currentFirst As String - Dim nextFirst As String - currentFirst = Trim(ws.Cells(startRow, sortColumn).Value) - nextFirst = Trim(ws.Cells(startRow + 1, sortColumn).Value) - - If currentFirst <> "" And nextFirst <> "" Then - If currentFirst > nextFirst Then - sortOrder = xlAscending - Else - sortOrder = xlDescending - End If - Else - sortOrder = xlAscending - End If - - ws.Range(ws.Cells(startRow, 1), ws.Cells(lastRow, 20)).Sort _ - Key1:=ws.Cells(startRow, sortColumn), _ - Order1:=sortOrder, _ - Header:=xlNo -End Sub - -Sub ToggleAutoFilter(Optional ByVal filterRow As Long = 6) - Dim ws As Worksheet - Set ws = ActiveSheet - - ' Check if auto filter is already on - If ws.AutoFilterMode Then - ws.AutoFilterMode = False - Else - If filterRow >= 1 Then - ws.Rows(filterRow).AutoFilter - End If - End If -End Sub - -Sub AutoFitColumnWidth(Optional ByVal fitColumnStart As Long = 2, Optional ByVal fitColumnEnd As Long = 9) - Dim ws As Worksheet - Set ws = ActiveSheet - - If fitColumnStart <= fitColumnEnd Then - ws.Range(ws.Columns(fitColumnStart), ws.Columns(fitColumnEnd)).AutoFit - End If -End Sub +' ============================================================ +' Common Functions +' ============================================================ + +Function CleanCSVField(ByVal inputStr As String) As String + Dim s As String + s = Trim(inputStr) + + ' calcute + If Len(s) > 0 Then + Select Case Left(s, 1) + Case "=", "+", "-", "@" + CleanCSVField = "'" & s + Exit Function + End Select + End If + + CleanCSVField = s +End Function + +Function GetLastDataRow(ByVal ws As Worksheet, ByVal columnNum As Long) As Long + GetLastDataRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row +End Function + +Sub ClearDataRows(ByVal ws As Worksheet, ByVal startRow As Long, ByVal columnNum As Long) + Dim lastRow As Long + lastRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row + + If lastRow >= startRow Then + ws.Range(ws.Cells(startRow, 1), ws.Cells(lastRow, 20)).ClearContents + End If +End Sub + +Sub SortDataRows(Optional ByVal sortColumn As Long = 3) + Dim ws As Worksheet + Dim lastRow As Long + Dim startRow As Long + Dim sortOrder As Long + + Set ws = ActiveSheet + startRow = 7 + lastRow = GetLastDataRow(ws, sortColumn) + + If lastRow < startRow Then + MsgBox "No data to sort.", vbExclamation + Exit Sub + End If + + ' Determine sort order based on first row's current state + Dim currentFirst As String + Dim nextFirst As String + currentFirst = Trim(ws.Cells(startRow, sortColumn).Value) + nextFirst = Trim(ws.Cells(startRow + 1, sortColumn).Value) + + If currentFirst <> "" And nextFirst <> "" Then + If currentFirst > nextFirst Then + sortOrder = xlAscending + Else + sortOrder = xlDescending + End If + Else + sortOrder = xlAscending + End If + + ws.Range(ws.Cells(startRow, 1), ws.Cells(lastRow, 20)).Sort _ + Key1:=ws.Cells(startRow, sortColumn), _ + Order1:=sortOrder, _ + Header:=xlNo +End Sub + +Sub ToggleAutoFilter(Optional ByVal filterRow As Long = 6) + Dim ws As Worksheet + Set ws = ActiveSheet + + ' Check if auto filter is already on + If ws.AutoFilterMode Then + ws.AutoFilterMode = False + Else + If filterRow >= 1 Then + ws.Rows(filterRow).AutoFilter + End If + End If +End Sub + +Sub AutoFitColumnWidth(Optional ByVal fitColumnStart As Long = 2, Optional ByVal fitColumnEnd As Long = 9) + Dim ws As Worksheet + Set ws = ActiveSheet + + If fitColumnStart <= fitColumnEnd Then + ws.Range(ws.Columns(fitColumnStart), ws.Columns(fitColumnEnd)).AutoFit + End If +End Sub diff --git a/src/module/Read_Common.bas b/src/module/Read_Common.bas index 3cb1d65..9b4d3a9 100644 --- a/src/module/Read_Common.bas +++ b/src/module/Read_Common.bas @@ -1,168 +1,168 @@ -Function SelectCSVFile() As String - Dim fileDialog As FileDialog - Set fileDialog = Application.FileDialog(msoFileDialogFilePicker) - - With fileDialog - .Filters.Clear - .Filters.Add "CSV Files", "*.csv" - .AllowMultiSelect = False - If .Show <> -1 Then - SelectCSVFile = "" - Exit Function - End If - SelectCSVFile = .SelectedItems(1) - End With -End Function - -' Read a CSV file and return its content as a strict 2D array (1-based). -' 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", "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 - - 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 - .Open - .LoadFromFile filePath - Dim textContent As String - textContent = .ReadText - .Close - End With - - ' === stardand === - textContent = Replace(textContent, vbCrLf, vbLf) - textContent = Replace(textContent, vbCr, vbLf) - - ' === transfer into collection === - Dim lines As Collection - Set lines = ParseCSVLines(textContent) - - ' === validate empty === - If lines.Count = 0 Then - Err.Raise 5003, , "CSV file is empty." - End If - - ' === loop the row, validate column count === - Dim i As Long - For i = 1 To lines.Count - Dim rowArr As Variant - rowArr = lines(i) - Dim actualCols As Long - actualCols = UBound(rowArr) - LBound(rowArr) + 1 - - If actualCols <> expectedColumnCount Then - Err.Raise 5004, , "Row " & i & ": Expected " & expectedColumnCount & " columns, got " & actualCols & "." - End If - Next i - - Dim result As Variant - ReDim result(1 To lines.Count, 1 To expectedColumnCount) - - For i = 1 To lines.Count - rowArr = lines(i) - Dim j As Long - For j = LBound(rowArr) To UBound(rowArr) - result(i, j - LBound(rowArr) + 1) = rowArr(j) - Next j - Next i - - ReadCSVAs2DArrayStrict = result -End Function - -' 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) - If length = 0 Then Exit Function - - Dim i As Long: i = 1 - Dim currentField As String - 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 - If i < length And Mid$(csvText, i + 1, 1) = """" Then - currentField = currentField & """" - i = i + 2 - Else - inQuotes = False - i = i + 1 - End If - Else - inQuotes = True - i = i + 1 - End If - Case "," - If inQuotes Then - currentField = currentField & c - i = i + 1 - Else - currentRow.Add currentField - currentField = "" - i = i + 1 - End If - Case vbLf - If inQuotes Then - currentField = currentField & c - i = i + 1 - Else - currentRow.Add currentField - Dim arr() As String - If currentRow.Count > 0 Then - ReDim arr(0 To currentRow.Count - 1) - Dim k As Long - For k = 1 To currentRow.Count - arr(k - 1) = currentRow(k) - Next k - End If - ParseCSVLines.Add arr - 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 without trailing newline - If currentField <> "" Or currentRow.Count > 0 Then - currentRow.Add currentField - Dim lastArr() As String - If currentRow.Count > 0 Then - ReDim lastArr(0 To currentRow.Count - 1) - Dim m As Long - For m = 1 To currentRow.Count - lastArr(m - 1) = currentRow(m) - Next m - End If - ParseCSVLines.Add lastArr - End If +Function SelectCSVFile() As String + Dim fileDialog As FileDialog + Set fileDialog = Application.FileDialog(msoFileDialogFilePicker) + + With fileDialog + .Filters.Clear + .Filters.Add "CSV Files", "*.csv" + .AllowMultiSelect = False + If .Show <> -1 Then + SelectCSVFile = "" + Exit Function + End If + SelectCSVFile = .SelectedItems(1) + End With +End Function + +' Read a CSV file and return its content as a strict 2D array (1-based). +' 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", "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 + + 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 + .Open + .LoadFromFile filePath + Dim textContent As String + textContent = .ReadText + .Close + End With + + ' === stardand === + textContent = Replace(textContent, vbCrLf, vbLf) + textContent = Replace(textContent, vbCr, vbLf) + + ' === transfer into collection === + Dim lines As Collection + Set lines = ParseCSVLines(textContent) + + ' === validate empty === + If lines.Count = 0 Then + Err.Raise 5003, , "CSV file is empty." + End If + + ' === loop the row, validate column count === + Dim i As Long + For i = 1 To lines.Count + Dim rowArr As Variant + rowArr = lines(i) + Dim actualCols As Long + actualCols = UBound(rowArr) - LBound(rowArr) + 1 + + If actualCols <> expectedColumnCount Then + Err.Raise 5004, , "Row " & i & ": Expected " & expectedColumnCount & " columns, got " & actualCols & "." + End If + Next i + + Dim result As Variant + ReDim result(1 To lines.Count, 1 To expectedColumnCount) + + For i = 1 To lines.Count + rowArr = lines(i) + Dim j As Long + For j = LBound(rowArr) To UBound(rowArr) + result(i, j - LBound(rowArr) + 1) = rowArr(j) + Next j + Next i + + ReadCSVAs2DArrayStrict = result +End Function + +' 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) + If length = 0 Then Exit Function + + Dim i As Long: i = 1 + Dim currentField As String + 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 + If i < length And Mid$(csvText, i + 1, 1) = """" Then + currentField = currentField & """" + i = i + 2 + Else + inQuotes = False + i = i + 1 + End If + Else + inQuotes = True + i = i + 1 + End If + Case "," + If inQuotes Then + currentField = currentField & c + i = i + 1 + Else + currentRow.Add currentField + currentField = "" + i = i + 1 + End If + Case vbLf + If inQuotes Then + currentField = currentField & c + i = i + 1 + Else + currentRow.Add currentField + Dim arr() As String + If currentRow.Count > 0 Then + ReDim arr(0 To currentRow.Count - 1) + Dim k As Long + For k = 1 To currentRow.Count + arr(k - 1) = currentRow(k) + Next k + End If + ParseCSVLines.Add arr + 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 without trailing newline + If currentField <> "" Or currentRow.Count > 0 Then + currentRow.Add currentField + Dim lastArr() As String + If currentRow.Count > 0 Then + ReDim lastArr(0 To currentRow.Count - 1) + Dim m As Long + For m = 1 To currentRow.Count + lastArr(m - 1) = currentRow(m) + Next m + End If + ParseCSVLines.Add lastArr + End If End Function \ No newline at end of file diff --git a/src/module/Write_Common.bas b/src/module/Write_Common.bas index e1324fb..35b910c 100644 --- a/src/module/Write_Common.bas +++ b/src/module/Write_Common.bas @@ -1,138 +1,138 @@ -Function GetSaveCSVPath(Optional ByVal defaultName As String = "") As String - Dim savePath As String - savePath = Application.GetSaveAsFilename( _ - FileFilter:="CSV Files (*.csv), *.csv", _ - Title:="Save CSV", _ - InitialFileName:=defaultName) - - If savePath = "False" Or savePath = "" Then - GetSaveCSVPath = "" - Exit Function - End If - - If InStr(1, savePath, ".csv", vbTextCompare) = 0 Then - savePath = savePath & ".csv" - End If - - GetSaveCSVPath = savePath -End Function - -' 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 +Function GetSaveCSVPath(Optional ByVal defaultName As String = "") As String + Dim savePath As String + savePath = Application.GetSaveAsFilename( _ + FileFilter:="CSV Files (*.csv), *.csv", _ + Title:="Save CSV", _ + InitialFileName:=defaultName) + + If savePath = "False" Or savePath = "" Then + GetSaveCSVPath = "" + Exit Function + End If + + If InStr(1, savePath, ".csv", vbTextCompare) = 0 Then + savePath = savePath & ".csv" + End If + + GetSaveCSVPath = savePath +End Function + +' 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/src/thisWorkbook/Kotsu_master.bas b/src/thisWorkbook/Kotsu_master.bas index f643221..356512c 100644 --- a/src/thisWorkbook/Kotsu_master.bas +++ b/src/thisWorkbook/Kotsu_master.bas @@ -1,226 +1,226 @@ -Sub Z1_ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long) - ws.Range(ws.Cells(rowNum, 4), ws.Cells(rowNum, 15)).ClearContents - ws.Cells(rowNum, 2).ClearContents -End Sub - -Sub Z1_ImportMasterDetailData() - Dim filePath As String - Dim wsTarget As Worksheet - Dim lines As Variant - Dim i As Long - Dim dataArray As Variant - Dim code As String - 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 and return 2D array - lines = ReadCSVAs2DArrayStrict(filePath, 7, "utf-8") - - ' Step 3: Clear data rows - Call ClearDataRows(wsTarget, 7, 3) - - ' Step 4: Import data - writeRow = 7 - 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() - Dim ws As Worksheet - Dim lastDataRow As Long - Dim savePath As String - Dim r As Long - Dim rowCount As Long - Dim dataArray() As Variant - Dim dataIdx As Long - Dim j As Long - - Set ws = ActiveSheet - - lastDataRow = GetLastDataRow(ws, 3) - - If lastDataRow < 7 Then - MsgBox "No data rows to output.", vbExclamation - Exit Sub - End If - - savePath = GetSaveCSVPath() - If savePath = "" Then Exit Sub - - ' 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 - End If - Next r - - ' If no data, exit - If rowCount = 0 Then - MsgBox "No data rows to output.", vbExclamation - Exit Sub - End If - - ' 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 - -Sub Z1_validateDetailData(ByVal ws As Worksheet, ByVal rowNum As Long) - Dim cValue As String - cValue = Trim(ws.Cells(rowNum, 3).Value) - - If cValue = "" Then - ws.Cells(rowNum, 2).Value = "C column is required" - Exit Sub - End If - - If Len(cValue) <> 3 Then - ws.Cells(rowNum, 2).Value = "C column must be 3 characters" - Exit Sub - End If - - Dim i As Long - Dim ch As String - For i = 1 To 3 - ch = Mid(cValue, i, 1) - If Not ((ch >= "0" And ch <= "9") Or (ch >= "A" And ch <= "Z") Or (ch >= "a" And ch <= "z")) Then - ws.Cells(rowNum, 2).Value = "C column must be alphanumeric" - Exit Sub - End If - Next i - - Dim dValue As String - dValue = Trim(ws.Cells(rowNum, 4).Value) - If dValue = "" Then - ws.Cells(rowNum, 2).Value = "D column is required" - Exit Sub - End If - If Len(dValue) > 80 Then - ws.Cells(rowNum, 2).Value = "D column must be within 80 characters" - Exit Sub - End If - - Dim eValue As String - eValue = Trim(ws.Cells(rowNum, 5).Value) - If eValue = "" Then - ws.Cells(rowNum, 2).Value = "E column is required" - Exit Sub - End If - If Len(eValue) > 80 Then - ws.Cells(rowNum, 2).Value = "E column must be within 80 characters" - Exit Sub - End If - - Dim fValue As String - fValue = Trim(ws.Cells(rowNum, 6).Value) - If fValue <> "" And Len(fValue) > 80 Then - ws.Cells(rowNum, 2).Value = "F column must be within 80 characters" - Exit Sub - End If - - Dim gValue As String - gValue = Trim(ws.Cells(rowNum, 7).Value) - If gValue <> "" And Len(gValue) > 80 Then - ws.Cells(rowNum, 2).Value = "G column must be within 80 characters" - Exit Sub - End If - - Dim iValue As String - iValue = Trim(ws.Cells(rowNum, 9).Value) - If iValue <> "" And Len(iValue) > 80 Then - ws.Cells(rowNum, 2).Value = "I column must be within 80 characters" - Exit Sub - End If - - Dim hValue As String - hValue = Trim(ws.Cells(rowNum, 8).Value) - If hValue <> "" Then - If Len(hValue) <> 1 Then - ws.Cells(rowNum, 2).Value = "H column must be 1 digit" - Exit Sub - End If - If hValue <> "0" And hValue <> "1" Then - ws.Cells(rowNum, 2).Value = "H column must be 0 or 1" - Exit Sub - End If - End If - - ws.Cells(rowNum, 2).ClearContents -End Sub - -Sub Z1_validateDetailDataButton() - Dim ws As Worksheet - Dim lastRow As Long - Dim r As Long - Dim errorCount As Long - - Set ws = ActiveSheet - lastRow = GetLastDataRow(ws, 3) - - If lastRow < 7 Then - MsgBox "No data found.", vbExclamation - Exit Sub - End If - - errorCount = 0 - For r = 7 To lastRow - Call Z1_validateDetailData(ws, r) - If Trim(ws.Cells(r, 2).Value) <> "" Then - errorCount = errorCount + 1 - End If - Next r - - MsgBox "Validation complete. Errors: " & errorCount, vbInformation -End Sub - -Sub Z1_SortDataRowsByC() - Call SortDataRows(3) -End Sub - -Sub Z1_ToggleAutoFilter() - Call ToggleAutoFilter(6) -End Sub - -Sub Z1_AutoFitColumnWidth() - Call AutoFitColumnWidth() +Sub Z1_ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long) + ws.Range(ws.Cells(rowNum, 4), ws.Cells(rowNum, 15)).ClearContents + ws.Cells(rowNum, 2).ClearContents +End Sub + +Sub Z1_ImportMasterDetailData() + Dim filePath As String + Dim wsTarget As Worksheet + Dim lines As Variant + Dim i As Long + Dim dataArray As Variant + Dim code As String + 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 and return 2D array + lines = ReadCSVAs2DArrayStrict(filePath, 7, "utf-8") + + ' Step 3: Clear data rows + Call ClearDataRows(wsTarget, 7, 3) + + ' Step 4: Import data + writeRow = 7 + 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() + Dim ws As Worksheet + Dim lastDataRow As Long + Dim savePath As String + Dim r As Long + Dim rowCount As Long + Dim dataArray() As Variant + Dim dataIdx As Long + Dim j As Long + + Set ws = ActiveSheet + + lastDataRow = GetLastDataRow(ws, 3) + + If lastDataRow < 7 Then + MsgBox "No data rows to output.", vbExclamation + Exit Sub + End If + + savePath = GetSaveCSVPath() + If savePath = "" Then Exit Sub + + ' 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 + End If + Next r + + ' If no data, exit + If rowCount = 0 Then + MsgBox "No data rows to output.", vbExclamation + Exit Sub + End If + + ' 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 + +Sub Z1_validate(ByVal ws As Worksheet, ByVal rowNum As Long) + Dim cValue As String + cValue = Trim(ws.Cells(rowNum, 3).Value) + + If cValue = "" Then + ws.Cells(rowNum, 2).Value = "C column is required" + Exit Sub + End If + + If Len(cValue) <> 3 Then + ws.Cells(rowNum, 2).Value = "C column must be 3 characters" + Exit Sub + End If + + Dim i As Long + Dim ch As String + For i = 1 To 3 + ch = Mid(cValue, i, 1) + If Not ((ch >= "0" And ch <= "9") Or (ch >= "A" And ch <= "Z") Or (ch >= "a" And ch <= "z")) Then + ws.Cells(rowNum, 2).Value = "C column must be alphanumeric" + Exit Sub + End If + Next i + + Dim dValue As String + dValue = Trim(ws.Cells(rowNum, 4).Value) + If dValue = "" Then + ws.Cells(rowNum, 2).Value = "D column is required" + Exit Sub + End If + If Len(dValue) > 80 Then + ws.Cells(rowNum, 2).Value = "D column must be within 80 characters" + Exit Sub + End If + + Dim eValue As String + eValue = Trim(ws.Cells(rowNum, 5).Value) + If eValue = "" Then + ws.Cells(rowNum, 2).Value = "E column is required" + Exit Sub + End If + If Len(eValue) > 80 Then + ws.Cells(rowNum, 2).Value = "E column must be within 80 characters" + Exit Sub + End If + + Dim fValue As String + fValue = Trim(ws.Cells(rowNum, 6).Value) + If fValue <> "" And Len(fValue) > 80 Then + ws.Cells(rowNum, 2).Value = "F column must be within 80 characters" + Exit Sub + End If + + Dim gValue As String + gValue = Trim(ws.Cells(rowNum, 7).Value) + If gValue <> "" And Len(gValue) > 80 Then + ws.Cells(rowNum, 2).Value = "G column must be within 80 characters" + Exit Sub + End If + + Dim iValue As String + iValue = Trim(ws.Cells(rowNum, 9).Value) + If iValue <> "" And Len(iValue) > 80 Then + ws.Cells(rowNum, 2).Value = "I column must be within 80 characters" + Exit Sub + End If + + Dim hValue As String + hValue = Trim(ws.Cells(rowNum, 8).Value) + If hValue <> "" Then + If Len(hValue) <> 1 Then + ws.Cells(rowNum, 2).Value = "H column must be 1 digit" + Exit Sub + End If + If hValue <> "0" And hValue <> "1" Then + ws.Cells(rowNum, 2).Value = "H column must be 0 or 1" + Exit Sub + End If + End If + + ws.Cells(rowNum, 2).ClearContents +End Sub + +Sub Z1_validateButton() + Dim ws As Worksheet + Dim lastRow As Long + Dim r As Long + Dim errorCount As Long + + Set ws = ActiveSheet + lastRow = GetLastDataRow(ws, 3) + + If lastRow < 7 Then + MsgBox "No data found.", vbExclamation + Exit Sub + End If + + errorCount = 0 + For r = 7 To lastRow + Call Z1_validate(ws, r) + If Trim(ws.Cells(r, 2).Value) <> "" Then + errorCount = errorCount + 1 + End If + Next r + + MsgBox "Validation complete. Errors: " & errorCount, vbInformation +End Sub + +Sub Z1_SortDataRowsByC() + Call SortDataRows(3) +End Sub + +Sub Z1_ToggleAutoFilter() + Call ToggleAutoFilter(6) +End Sub + +Sub Z1_AutoFitColumnWidth() + Call AutoFitColumnWidth() End Sub \ No newline at end of file diff --git a/~$通勤手当テンプレート_案.xlsm b/~$通勤手当テンプレート_案.xlsm new file mode 100644 index 0000000..9e43c9c Binary files /dev/null and b/~$通勤手当テンプレート_案.xlsm differ diff --git a/通勤手当テンプレート_案.xlsm b/通勤手当テンプレート_案.xlsm index bd1fd7b..513e5d0 100644 Binary files a/通勤手当テンプレート_案.xlsm and b/通勤手当テンプレート_案.xlsm differ