modify ReadCSVAs2DArrayStrict
This commit is contained in:
updsv7
@@ -2,49 +2,20 @@
|
||||
' Common Functions
|
||||
' ============================================================
|
||||
|
||||
Function CleanCSVField(ByVal field As Variant) As String
|
||||
If IsEmpty(field) Or IsNull(field) Then
|
||||
CleanCSVField = ""
|
||||
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
|
||||
|
||||
Dim result As String
|
||||
result = Trim(CStr(field))
|
||||
|
||||
If Len(result) >= 2 Then
|
||||
If Left(result, 1) = """" And Right(result, 1) = """" Then
|
||||
result = Mid(result, 2, Len(result) - 2)
|
||||
result = Replace(result, """""", """")
|
||||
End If
|
||||
End If
|
||||
|
||||
CleanCSVField = result
|
||||
End Function
|
||||
|
||||
Function ValidateCSVColumnCount(ByVal lines As Variant, ByVal expectedColumns As Long) As Boolean
|
||||
ValidateCSVColumnCount = True
|
||||
|
||||
Dim lineNum As Long
|
||||
Dim dataArray As Variant
|
||||
Dim validRowCount As Long
|
||||
validRowCount = 0
|
||||
|
||||
For lineNum = 0 To UBound(lines)
|
||||
If Trim(lines(lineNum)) <> "" Then
|
||||
dataArray = Split(lines(lineNum), ",")
|
||||
If UBound(dataArray) + 1 <> expectedColumns Then
|
||||
MsgBox "CSV line " & (lineNum + 1) & " has " & (UBound(dataArray) + 1) & " columns. Expected " & expectedColumns & ".", vbExclamation
|
||||
ValidateCSVColumnCount = False
|
||||
Exit Function
|
||||
End If
|
||||
validRowCount = validRowCount + 1
|
||||
End If
|
||||
Next lineNum
|
||||
|
||||
If validRowCount = 0 Then
|
||||
MsgBox "No valid data in CSV.", vbExclamation
|
||||
ValidateCSVColumnCount = False
|
||||
End If
|
||||
CleanCSVField = s
|
||||
End Function
|
||||
|
||||
Function GetLastDataRow(ByVal ws As Worksheet, ByVal columnNum As Long) As Long
|
||||
@@ -109,47 +80,34 @@ Sub WriteCSVFile(ByVal filePath As String, ByVal content As String)
|
||||
End With
|
||||
End Sub
|
||||
|
||||
|
||||
Function ReadCSVFile(ByVal filePath As String, Optional ByVal charset As String = "shift_jis") As Variant
|
||||
If filePath = "" Then
|
||||
ReadCSVFile = Array()
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
Dim stream As Object
|
||||
Dim textContent As String
|
||||
|
||||
Set stream = CreateObject("ADODB.Stream")
|
||||
With stream
|
||||
.Type = 2
|
||||
.Charset = charset
|
||||
.Open
|
||||
.LoadFromFile filePath
|
||||
textContent = .ReadText
|
||||
.Close
|
||||
End With
|
||||
|
||||
ReadCSVFile = Split(textContent, vbLf)
|
||||
End Function
|
||||
|
||||
' Read a CSV file and return its content as a strict 2D array (1-based).
|
||||
' The function ensures all rows have the same number of columns as the first row.
|
||||
' If any row has a different column count, an error is raised immediately.
|
||||
' 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" for Shift-JIS, "utf-8" for UTF-8).
|
||||
Function ReadCSVAs2DArrayStrict(ByVal filePath As String, Optional ByVal charset As String = "cp932") As Variant
|
||||
' Check if file exists
|
||||
If filePath = "" Or Dir(filePath) = "" Then
|
||||
Err.Raise vbObjectError + 1001, , "File not found: " & filePath
|
||||
' 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
|
||||
|
||||
' Read entire file using ADODB.Stream with specified character set
|
||||
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
|
||||
.charset = charset
|
||||
.Open
|
||||
.LoadFromFile filePath
|
||||
Dim textContent As String
|
||||
@@ -157,93 +115,66 @@ Function ReadCSVAs2DArrayStrict(ByVal filePath As String, Optional ByVal charset
|
||||
.Close
|
||||
End With
|
||||
|
||||
' Handle empty file
|
||||
If textContent = "" Then
|
||||
Err.Raise vbObjectError + 1002, , "CSV file is empty"
|
||||
End If
|
||||
|
||||
' Normalize line breaks to vbLf (\n)
|
||||
' === stardand ===
|
||||
textContent = Replace(textContent, vbCrLf, vbLf)
|
||||
textContent = Replace(textContent, vbCr, vbLf)
|
||||
|
||||
' Parse CSV lines into a collection of string arrays
|
||||
' === transfer into collection ===
|
||||
Dim lines As Collection
|
||||
Set lines = ParseCSVLines(textContent)
|
||||
|
||||
' === validate empty ===
|
||||
If lines.Count = 0 Then
|
||||
Err.Raise vbObjectError + 1003, , "No valid rows parsed from CSV"
|
||||
Err.Raise 5003, , "CSV file is empty."
|
||||
End If
|
||||
|
||||
' Determine expected column count from the first row
|
||||
Dim expectedCols As Long
|
||||
Dim firstRow As Variant
|
||||
firstRow = lines(1)
|
||||
expectedCols = UBound(firstRow) - LBound(firstRow) + 1
|
||||
|
||||
If expectedCols <= 0 Then
|
||||
Err.Raise vbObjectError + 1004, , "First row contains no fields"
|
||||
End If
|
||||
|
||||
' Validate every row has exactly expectedCols columns
|
||||
' === loop the row, validate column count ===
|
||||
Dim i As Long
|
||||
For i = 1 To lines.Count
|
||||
Dim currentRow As Variant
|
||||
currentRow = lines(i)
|
||||
Dim rowArr As Variant
|
||||
rowArr = lines(i)
|
||||
Dim actualCols As Long
|
||||
actualCols = UBound(currentRow) - LBound(currentRow) + 1
|
||||
actualCols = UBound(rowArr) - LBound(rowArr) + 1
|
||||
|
||||
If actualCols <> expectedCols Then
|
||||
Err.Raise vbObjectError + 1005, , _
|
||||
"CSV row column count mismatch!" & vbCrLf & _
|
||||
"Expected columns: " & expectedCols & vbCrLf & _
|
||||
"Row " & i & " has " & actualCols & " columns."
|
||||
If actualCols <> expectedColumnCount Then
|
||||
Err.Raise 5004, , "Row " & i & ": Expected " & expectedColumnCount & " columns, got " & actualCols & "."
|
||||
End If
|
||||
Next i
|
||||
|
||||
' Build 1-based 2D result array (no padding needed due to strict validation)
|
||||
Dim result As Variant
|
||||
ReDim result(1 To lines.Count, 1 To expectedCols)
|
||||
ReDim result(1 To lines.Count, 1 To expectedColumnCount)
|
||||
|
||||
For i = 1 To lines.Count
|
||||
currentRow = lines(i)
|
||||
rowArr = lines(i)
|
||||
Dim j As Long
|
||||
For j = LBound(currentRow) To UBound(currentRow)
|
||||
result(i, j - LBound(currentRow) + 1) = currentRow(j)
|
||||
For j = LBound(rowArr) To UBound(rowArr)
|
||||
result(i, j - LBound(rowArr) + 1) = rowArr(j)
|
||||
Next j
|
||||
Next i
|
||||
|
||||
ReadCSVAs2DArrayStrict = result
|
||||
End Function
|
||||
|
||||
' Parse CSV text into a Collection of string arrays, respecting RFC 4180 rules.
|
||||
' Handles quoted fields, commas/line breaks inside quotes, and escaped quotes ("").
|
||||
' Input: CSV text with normalized line endings (vbLf only).
|
||||
' Output: Collection where each item is a zero-based array of field strings.
|
||||
' 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)
|
||||
Dim length As Long: length = Len(csvText)
|
||||
If length = 0 Then Exit Function
|
||||
|
||||
Dim i As Long
|
||||
i = 1
|
||||
Dim i As Long: i = 1
|
||||
Dim currentField As String
|
||||
Dim currentRow As Collection
|
||||
Set currentRow = New Collection
|
||||
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
|
||||
' Check for escaped quote ("")
|
||||
If i < length And Mid$(csvText, i + 1, 1) = """" Then
|
||||
currentField = currentField & """"
|
||||
i = i + 2 ' Skip both quotes
|
||||
i = i + 2
|
||||
Else
|
||||
inQuotes = False
|
||||
i = i + 1
|
||||
@@ -252,26 +183,21 @@ Private Function ParseCSVLines(ByVal csvText As String) As Collection
|
||||
inQuotes = True
|
||||
i = i + 1
|
||||
End If
|
||||
|
||||
Case ","
|
||||
If inQuotes Then
|
||||
currentField = currentField & c
|
||||
i = i + 1
|
||||
Else
|
||||
' End of field
|
||||
currentRow.Add currentField
|
||||
currentField = ""
|
||||
i = i + 1
|
||||
End If
|
||||
|
||||
Case vbLf
|
||||
If inQuotes Then
|
||||
currentField = currentField & c
|
||||
i = i + 1
|
||||
Else
|
||||
' End of row
|
||||
currentRow.Add currentField
|
||||
' Convert collection to array
|
||||
Dim arr() As String
|
||||
If currentRow.Count > 0 Then
|
||||
ReDim arr(0 To currentRow.Count - 1)
|
||||
@@ -281,20 +207,18 @@ Private Function ParseCSVLines(ByVal csvText As String) As Collection
|
||||
Next k
|
||||
End If
|
||||
ParseCSVLines.Add arr
|
||||
' Reset for next row
|
||||
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 if file doesn't end with newline
|
||||
' Handle last row without trailing newline
|
||||
If currentField <> "" Or currentRow.Count > 0 Then
|
||||
currentRow.Add currentField
|
||||
Dim lastArr() As String
|
||||
|
||||
@@ -13,40 +13,40 @@ Sub Z1_ImportMasterDetailData()
|
||||
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
|
||||
lines = ReadCSVFile(filePath, "utf-8")
|
||||
' Step 2: Read CSV and return 2D array
|
||||
lines = ReadCSVAs2DArrayStrict(filePath, 7, "utf-8")
|
||||
|
||||
' Step 3: Validate column count
|
||||
If Not ValidateCSVColumnCount(lines, 7) Then Exit Sub
|
||||
|
||||
' Step 4: Clear data rows
|
||||
' Step 3: Clear data rows
|
||||
Call ClearDataRows(wsTarget, 7, 3)
|
||||
|
||||
' Step 5: Import data
|
||||
' Step 4: Import data
|
||||
writeRow = 7
|
||||
|
||||
For i = 0 To UBound(lines)
|
||||
If Trim(lines(i)) <> "" Then
|
||||
dataArray = Split(lines(i), ",")
|
||||
|
||||
wsTarget.Cells(writeRow, 3).Value = CleanCSVField(CStr(dataArray(0)))
|
||||
wsTarget.Cells(writeRow, 4).Value = CleanCSVField(CStr(dataArray(1)))
|
||||
wsTarget.Cells(writeRow, 5).Value = CleanCSVField(CStr(dataArray(2)))
|
||||
wsTarget.Cells(writeRow, 6).Value = CleanCSVField(CStr(dataArray(3)))
|
||||
wsTarget.Cells(writeRow, 7).Value = CleanCSVField(CStr(dataArray(4)))
|
||||
wsTarget.Cells(writeRow, 8).Value = CleanCSVField(CStr(dataArray(5)))
|
||||
wsTarget.Cells(writeRow, 9).Value = CleanCSVField(CStr(dataArray(6)))
|
||||
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()
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user