updsv7/vba
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

divide common module into write and read

Browse Source
This commit is contained in:
updsv7
2026-04-14 15:52:33 +09:00
parent b87618dcf3
commit 13d23281b7
3 changed files with 187 additions and 202 deletions
Download Patch File Download Diff File Expand all files Collapse all files

202
vba_code_common.bas
View File

@@ -31,208 +31,6 @@ Sub ClearDataRows(ByVal ws As Worksheet, ByVal startRow As Long, ByVal columnNum
End If End If
End Sub 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) Sub SortDataRows(Optional ByVal sortColumn As Long = 3)
Dim ws As Worksheet Dim ws As Worksheet
Dim lastRow As Long Dim lastRow As Long

168
vba_code_read_csv_common.bas Normal file
View File

@@ -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

19
vba_code_write_csv_common.bas
View File

@@ -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 ' Writes a 2D array to a CSV file
Sub WriteCSVFromArray( _ Sub WriteCSVFromArray( _
ByVal filePath As String, _ ByVal filePath As String, _