エクセル更新

vba_code_common.bas

@@ -132,6 +132,183 @@ Function ReadCSVFile(ByVal filePath As String, Optional ByVal charset As String
     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.
+' 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
+    End If
+    
+    ' Read entire file using ADODB.Stream with specified character set
+    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
+    
+    ' Handle empty file
+    If textContent = "" Then
+        Err.Raise vbObjectError + 1002, , "CSV file is empty"
+    End If
+    
+    ' Normalize line breaks to vbLf (\n)
+    textContent = Replace(textContent, vbCrLf, vbLf)
+    textContent = Replace(textContent, vbCr, vbLf)
+    
+    ' Parse CSV lines into a collection of string arrays
+    Dim lines As Collection
+    Set lines = ParseCSVLines(textContent)
+    
+    If lines.Count = 0 Then
+        Err.Raise vbObjectError + 1003, , "No valid rows parsed from CSV"
+    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
+    Dim i As Long
+    For i = 1 To lines.Count
+        Dim currentRow As Variant
+        currentRow = lines(i)
+        Dim actualCols As Long
+        actualCols = UBound(currentRow) - LBound(currentRow) + 1
+        
+        If actualCols <> expectedCols Then
+            Err.Raise vbObjectError + 1005, , _
+                "CSV row column count mismatch!" & vbCrLf & _
+                "Expected columns: " & expectedCols & vbCrLf & _
+                "Row " & i & " has " & actualCols & " columns."
+        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)
+    
+    For i = 1 To lines.Count
+        currentRow = lines(i)
+        Dim j As Long
+        For j = LBound(currentRow) To UBound(currentRow)
+            result(i, j - LBound(currentRow) + 1) = currentRow(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.
+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
+                    ' Check for escaped quote ("")
+                    If i < length And Mid$(csvText, i + 1, 1) = """" Then
+                        currentField = currentField & """"
+                        i = i + 2 ' Skip both quotes
+                    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
+                    ' 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)
+                        Dim k As Long
+                        For k = 1 To currentRow.Count
+                            arr(k - 1) = currentRow(k)
+                        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
+    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