我想根据某些条件导入CSV文件

我有两个不同的CSV文件，我从同一家银行我已经添加到我的谷歌驱动器的链接到文本文件：
CSV Files share
类型1：

Column A     Column B     Column C   Column D             Column E  Column F   Coumn G
 | ACCOUNT    |             |         |                    |          |         |               | 
 | ---        | ---         | ---     | ---                | ---      | ---     | ---           | 
 | FOR ACCOU  |             |         |                    |          |         |               | 
 | Date       | SERVICE FEE | Amount  | DESCRIPTION        | REFERENCE| Balance | CHEQUE NUMBER | 
 | 05/12/2023 | 0           | -27.74  | #FNB OBE  75423891 | 75423891 | 3352.01 | 0             | 
 | 05/12/2023 | 0           | -315.38 | #FNB OBE  75423891 | 75423891 | 3379.75 | 0             | 
 | 04/12/2023 | 0           | 5.01    | CASH MANAGEMENT CR |          | 3695.13 | 0         

|

字符串
第二类：

| ACCOUNT    |          |          |                       | 
 | ---        | ---      | ---      | ---                   | 
 |   ColumnA  | ColumnB  | ColumnC  |  ColumnD              |
 | Name:      |  John    |  Doe     |                       | 
 | Account:   | 44444444 |  [Bus    |                       | 
 | Balance:   | 111111.11| 1111.11  |                       | 
 |            |          |          |                       | 
 | Date       |  Amount  |  Balance |  Description          | 
 | 07/12/2023 | -18994.4 | 48713.71 | 7583439531            | 
 | 07/12/2023 | -4091.63 | 67708.09 |  ESKOM_KLEINWESTERFOR | 
 | 07/12/2023 | -18773.8 | 71799.72 |  ESKOM_7337416667     | 
 | 07/12/2023 | 50000    | 90573.47 |  INTERNET TRF FROM    |

型
两个CSV的布局是完全不同的。当我为类型1编写代码时，它工作得很好，但是当我试图调整代码以考虑类型2时，它变得混乱。
我的最终目标与此代码，它必须导入文件，无论格式的CSV文件到以下格式：

| Date       | Description        | Amount | 
 | 12/05/2023 | #FNB OBE  75423891 | -27.74 | 
 | 12/05/2023 | #FNB OBE  75423891 | -315.38|

型
适用于Type 1 CSV的代码：

Private Sub btnImportFNB_Click()
    Dim vFile, arIn, arOut()
    Dim wbCSV As Workbook
    Dim i As Long, lastRow As Long
    Dim t0 As Single

    'Select a text file through the file dialog.
    'Get the path and file name of the selected file to the variable.
    vFile = Application.GetOpenFilename("ExcelFile *.txt,*.txt;*.csv", _
        Title:="Select CSV file", MultiSelect:=False)

    'If you don't select a file, exit sub.
    If TypeName(vFile) = "Boolean" Then
        Application.ScreenUpdating = True
        Exit Sub
    End If
    t0 = Timer

    'The selected text file is imported into an Excel file. format:2 is csv, format:1 is tab
    Set wbCSV = Workbooks.Open(Filename:=vFile, Format:=2, ReadOnly:=True)

    'Bring all the contents of the sheet into an array
    'and close the text file
    With wbCSV.Sheets(1)
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        If lastRow < 4 Then Exit Sub ' If the last row is less than 4, exit sub
        ' Exclude the last row by adjusting the range
        arIn = .Range("A4:D" & lastRow).Value
        
        wbCSV.Close
    End With
    
    ' Filter rows where Column C is not equal to 0
    Dim filteredRows As Long
    For i = 1 To UBound(arIn, 1)
        If arIn(i, 3) <> 0 Then
            filteredRows = filteredRows + 1
        End If
    Next i
    
    ' Skip processing if there are no rows to import
    If filteredRows = 0 Then
        MsgBox "No rows to import.", vbInformation
        Exit Sub
    End If
    
    ' Re-dimension the output array based on the filtered rows
    ReDim Preserve arOut(1 To filteredRows, 1 To 3)
    
    ' Index for the filtered rows
    Dim filteredIndex As Long
    ' Re-initialize filteredIndex
    filteredIndex = 0
    
    ' Loop through the input array and import only non-zero rows
    For i = 1 To UBound(arIn, 1)
        If arIn(i, 3) <> 0 Then
            ' Increment filteredIndex for each valid row
            filteredIndex = filteredIndex + 1
            ' Adjust column numbers as needed
            arOut(filteredIndex, 1) = arIn(i, 1)
            arOut(filteredIndex, 2) = arIn(i, 4) ' Column D
            arOut(filteredIndex, 3) = arIn(i, 3) ' Column C
        End If
    Next i

    'write output array to sheet2
    With ThisWorkbook.Sheets(2)
        .UsedRange.Clear
        .Range("A1:C1") = Array("Date", "Description", "Amount")
        .Range("B:B").NumberFormat = "@"
        .Range("C:C").NumberFormat = "General"
        .Range("A2").Resize(filteredRows, 3).Value = arOut
        .Columns("A:C").AutoFit
    End With

    MsgBox "Done", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub

型
以下是我对类型2的另一种尝试：

Private Sub btnImportFNB_Click()
    Dim vFile, arIn, arOut()
    Dim wbCSV As Workbook
    Dim i As Long, lastRow As Long, lastCol As Long
    Dim t0 As Single

    'Select a text file through the file dialog.
    'Get the path and file name of the selected file to the variable.
    vFile = Application.GetOpenFilename("ExcelFile *.txt,*.txt;*.csv", _
        Title:="Select CSV file", MultiSelect:=False)

    'If you don't select a file, exit sub.
    If TypeName(vFile) = "Boolean" Then
        Application.ScreenUpdating = True
        Exit Sub
    End If
    t0 = Timer

    'The selected text file is imported into an Excel file. format:2 is csv, format:1 is tab
    Set wbCSV = Workbooks.Open(Filename:=vFile, Format:=2, ReadOnly:=True)

    'Bring all the contents of the sheet into an array
    'and close the text file
    With wbCSV.Sheets(1)
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        lastCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
        If lastCol > 7 Then ' If columns A to G have data
            If lastRow < 4 Then Exit Sub ' If the last row is less than 4, exit sub
            ' Exclude the last row by adjusting the range
            arIn = .Range("A4:D" & lastRow).Value
        Else ' If only columns A to D have data
            If lastRow < 8 Then Exit Sub ' If the last row is less than 8, exit sub
            ' Exclude the last row by adjusting the range
            arIn = .Range("A8:D" & lastRow).Value
        End If

        wbCSV.Close
    End With
    
    ' Filter rows where Column C is not equal to 0
    Dim filteredRows As Long
    For i = 1 To UBound(arIn, 1)
        If arIn(i, 3) <> 0 Then
            filteredRows = filteredRows + 1
        End If
    Next i
    
    ' Skip processing if there are no rows to import
    If filteredRows = 0 Then
        MsgBox "No rows to import.", vbInformation
        Exit Sub
    End If
    
    ' Re-dimension the output array based on the filtered rows
    ReDim Preserve arOut(1 To filteredRows, 1 To 3)
    
    ' Index for the filtered rows
    Dim filteredIndex As Long
    ' Re-initialize filteredIndex
    filteredIndex = 0
    
    ' Loop through the input array and import only non-zero rows
    For i = 1 To UBound(arIn, 1)
        If arIn(i, 3) <> 0 Then
            ' Increment filteredIndex for each valid row
            filteredIndex = filteredIndex + 1
            ' Adjust column numbers as needed
            arOut(filteredIndex, 1) = arIn(i, 1)
            arOut(filteredIndex, 2) = arIn(i, 4) ' Column D
            arOut(filteredIndex, 3) = arIn(i, 3) ' Column C
        End If
    Next i

    'write output array to sheet2
    With ThisWorkbook.Sheets(2)
        .UsedRange.Clear
        .Range("A1:C1") = Array("Date", "Description", "Amount")
        .Range("B:B").NumberFormat = "@"
        .Range("C:C").NumberFormat = "General"
        .Range("A2").Resize(filteredRows, 3).Value = arOut
        .Columns("A:C").AutoFit
    End With

    MsgBox "Done", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub

型
我的想法是，这两个CSV文件有不同数量的列，其中有数据，类型1有数据从A列到G和类型2只有从A到D，所以我希望它检查它有数据在A列到G，然后它必须导入它根据我的第一个代码的作品，但是，如果它只有数据从A列到D的代码需要调整为只导入列A，D和B

搜索标题行，然后将列标题Map到列号。

Option Explicit

Private Sub btnImportFNB_Click()

    Const COLHEAD = "Date,Description,Amount"

    Dim vFile, arIn, arOut
    Dim wbCSV As Workbook
    Dim t0 As Single

    'Select a text file through the file dialog.
    'Get the path and file name of the selected file to the variable.
    vFile = Application.GetOpenFilename("ExcelFile *.txt,*.txt;*.csv", _
        Title:="Select CSV file", MultiSelect:=False)

    'If you don't select a file, exit sub.
    If TypeName(vFile) = "Boolean" Then
        Application.ScreenUpdating = True
        Exit Sub
    End If
    t0 = Timer
    
    ' find header row
    Dim fso As Object, ts As Object, hrow As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.OpenTextFile(vFile)
    
    Do While ts.AtEndOfStream = False
       hrow = hrow + 1
       If LCase(ts.readline) Like "date*" Then Exit Do
    Loop
    ts.Close
    
    If hrow = 0 Then
        MsgBox "date header not found in " & vFile, vbCritical
        Exit Sub
    End If
    
    ' add .txt so that OpenText works
    fso.CopyFile vFile, vFile & ".txt"
    
    'The selected text file is imported into an Excel file. format:2 is csv, format:1 is tab
    'Set wbCSV = Workbooks.Open(Filename:=vFile, Format:=2, ReadOnly:=True, Local:=True)
    Workbooks.OpenText vFile & ".txt", StartRow:=hrow, _
        DataType:=xlDelimited, Comma:=True, FieldInfo:=Array(Array(1, 4))
               
    Set wbCSV = ActiveWorkbook

    'Bring all the contents of the sheet into an array
    'and close the text file
    With wbCSV.Sheets(1)
        arIn = .UsedRange.Value
        wbCSV.Close
    End With
    
    ' delete .txt file
    fso.DeleteFile (vFile & ".txt")
    
    ' process file
    Dim arCol: arCol = Split(COLHEAD, ",")
    If process(arIn, arOut, arCol) = False Then ' error
        Exit Sub
    End If
    
     'write output array to sheet2
    With ThisWorkbook.Sheets(2)
        .UsedRange.Clear
        .Range("A1:C1") = arCol
        .Range("A:A").NumberFormat = "dd/mm/yyyy"
        .Range("B:B").NumberFormat = "@"
        .Range("C:C").NumberFormat = "General"
        .Range("A2").Resize(UBound(arOut), 3).Value = arOut
        .Columns("A:C").AutoFit
    End With

    MsgBox "Done", vbInformation, Format(Timer - t0, "0.0 secs")

End Sub

Function process(ByRef arIn, ByRef arOut, arCol) As Boolean
     ' scan array
     Dim hr As Long, c As Long, i As Long, j As Long, k As Long
     Dim dictHdr As Object, v
     Set dictHdr = CreateObject("Scripting.Dictionary")
     
     ' find header and created col mappings
     For i = 1 To UBound(arIn)
         If LCase(arIn(i, 1)) = "date" Then
            ' map header text to columns
            For c = 1 To UBound(arIn, 2)
               dictHdr.Add Trim(LCase(arIn(i, c))), c
            Next
            hr = i
            Exit For
         End If
     Next
     
     ' check all columns found
     For Each v In arCol
         If Not dictHdr.exists(LCase(v)) Then
            MsgBox "Column " & v & " not found", vbCritical
            process = False
            Exit Function
         End If
     Next
     
     ' size output
     ReDim arOut(1 To UBound(arIn) - hr, 1 To UBound(arCol) + 1)
    
    ' copy celected columns
    ' filter out zero amounts
    k = 0
    For i = hr + 1 To UBound(arIn)
        If arIn(i, dictHdr("amount")) <> 0 Then
            k = k + 1
            For c = 0 To UBound(arCol)
                j = dictHdr(LCase(arCol(c)))
                arOut(k, c + 1) = arIn(i, j)
            Next
        End If
    Next
    
    ' no errors
    process = True

End Function

字符串

我想根据某些条件导入CSV文件

1条答案

相关问题

热门标签

最新问答