' ============================================================ ' Module Name: Read_Common ' Module Desc: CSV read functions ' Module Methods: ' - SelectCSVFile ' - ReadCSVAs2DArrayStrict ' - ParseCSVLines ' ============================================================ 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 ' === standardize === 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 If lines.Count = 1 Then If hasHeader Then Err.Raise 5005, , "CSV file data is empty." End If 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 Dim startRow As Long If hasHeader Then startRow = 2 Else startRow = 1 End If ReDim result(startRow To lines.Count, 1 To expectedColumnCount) For i = startRow 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 ' Clean field before adding currentField = Trim(currentField) currentField = Replace(currentField, vbCr, "") currentField = Replace(currentField, vbLf, "") 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 ' Clean field before adding currentField = Trim(currentField) currentField = Replace(currentField, vbCr, "") currentField = Replace(currentField, vbLf, "") 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