diff --git a/vba_code_common.bas b/vba_code_common.bas index 4243675..223f258 100644 --- a/vba_code_common.bas +++ b/vba_code_common.bas @@ -31,208 +31,6 @@ Sub ClearDataRows(ByVal ws As Worksheet, ByVal startRow As Long, ByVal columnNum End If End Sub -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 - - -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 - -Sub WriteCSVFile(ByVal filePath As String, ByVal content As String) - Dim stream As Object - Set stream = CreateObject("ADODB.Stream") - With stream - .Type = 2 - .Charset = "shift_jis" - .Open - .WriteText content, 0 - .SaveToFile filePath, 2 - .Close - End With -End Sub - -' 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 - Sub SortDataRows(Optional ByVal sortColumn As Long = 3) Dim ws As Worksheet Dim lastRow As Long diff --git a/vba_code_read_csv_common.bas b/vba_code_read_csv_common.bas new file mode 100644 index 0000000..3cb1d65 --- /dev/null +++ b/vba_code_read_csv_common.bas @@ -0,0 +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 +End Function \ No newline at end of file diff --git a/vba_code_write_csv_common.bas b/vba_code_write_csv_common.bas index 3b7bad8..e1324fb 100644 --- a/vba_code_write_csv_common.bas +++ b/vba_code_write_csv_common.bas @@ -1,3 +1,22 @@ +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, _