读取1000个CSV文件的内容

Question

我对VBA相当陌生，刚刚完成了我的第一个脚本。它正在完成我希望它做得很好的任务，但是这样做真的很慢。它必须为每个CSV过滤器打开和读取大约1000个特定行的CSV文件，并将这些文件复制到新创建的文档中的选项卡中。然后，它必须保存并关闭该新文档，并打开下一个CSV。

在脚本中是否有部分不是“良好实践”，因为它们严重地减慢了执行时间？

每次循环迭代大约需要3秒，所以所有1000个文件都需要50分钟。这台机器也已经崩溃了一半，虽然我不能百分之百肯定这是因为脚本。

Sub createLists()

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Dim startDate As Date
    Dim endDate As Date
    Dim dateLooper As Date
    Dim currDate As String

    'Set date range for existing files
    startDate = #1/1/2012#
    endDate = #9/12/2014#

    'Array, which contains names for new worksheets as strings
    Dim tsN(1 To 12) As String
    tsN(1) = "AA11"
    tsN(2) = "AA22"
    tsN(3) = "AA33"
    tsN(4) = "AA44"
    tsN(5) = "AA55"
    tsN(6) = "AA66"
    tsN(7) = "BB11"
    tsN(8) = "BB22"
    tsN(9) = "BB33"
    tsN(10) = "BB44"
    tsN(11) = "BB55"
    tsN(12) = "BB66"

    Dim w1 As Workbook
    Dim w2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet

    Dim localPath As String
    localPath = ThisWorkbook.path

    'Check for folder "Lists", create if non-existend
    Dim fso, folderN
    Set fso = CreateObject("Scripting.FileSystemObject")
    folderN = localPath & "\Lists\"
    If fso.FolderExists(folderN) = False Then MkDir folderN

    For dateLooper = startDate To endDate

        currDate = Format(dateLooper, "yyyy-mm-dd")

        'Open / create workbook objects
        Set w1 = Workbooks.Open(Filename:=localPath & "\roh\daten" & currDate & ".CSV", Local:=True)
        Set w2 = Workbooks.Add()

        'Array, which contains worksheet-objects which will reference new worksheets
        Dim ts(1 To 12) As Worksheet

        'Create new file and add/name new worksheets, set references to array ts
        For i = 1 To 12
            With w2.Sheets.Add()
                .Name = tsN(13 - i)
                .Activate
            End With
            If i = 1 Then w2.Worksheets(2).Delete
            Set ts(13 - i) = ActiveSheet
        Next i

        'Copy data:
        Set ws1 = w1.Sheets(1)

        'Iterate through products and copy corresponding data to seperate sheets in prev. created new file
        For i = 1 To 12
            Set ws2 = ts(i)

            'Filter data for product
            ws1.Range("A1:H1").AutoFilter Field:=2, Criteria1:="=" & tsN(i)
            ws1.Range("A1:H1").AutoFilter Field:=7, Criteria1:="=ja"

            'Select range and copy
            Dim lastRow As Long
            lastRow = ws1.UsedRange.Rows.Count
            ws1.Range("A1:H" & lastRow).Copy ws2.Range("A1:H1")

            'Sort copied data
            With ws2
                .Range("A1").Sort Key1:=.Range("D1"), Order1:=xlAscending, DataOption1:=xlSortNormal, Header:=xlYes
            End With

            ws1.AutoFilterMode = False
        Next i

        'Save newly created file
        w2.SaveAs Filename:=localPath & "\Lists\Lists-" & currDate & ".xls", FileFormat:=xlNormal
        w2.Close

        w1.Close

    Next dateLooper

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Answer 1

首先，使用早期绑定而不是后期绑定，以略微提高代码的性能，并利用智能感。

在VBE中，选择工具，然后引用。向下滚动到Microsoft Scripting Runtime并勾选复选框，将引用附加到项目。可以让你改变

Dim fso, folderN
Set fso = CreateObject("Scripting.FileSystemObject")

至

Dim fso As FileSystemObject, folderN As String
Set fso = New FileSystemObject

通常，您希望显式地淡化变量，避免使用Variant类型，因为它会使代码慢下来很多信不信！基本上，不要依赖运行时来计算变量的正确类型，因为这样做需要时间。

循环中有一个创建工作表的.Activate。它是多余的，只需增加开销->，删除它/注释掉它，并修改基于ActiveSheet的赋值

'Create new file and add/name new worksheets, set references to array ts 
For i = 1 To 12
    With w2.Sheets.Add()
        .Name = tsN(13 - i)
    End With
    If i = 1 Then w2.Worksheets(2).Delete
    Set ts(13 - i) = w2.Sheets(tsN(13 - i))
Next i

由于您当前读取数据的方法，其余的内容在我看来都很好。您的代码看起来相当干净，缩进得很好，并且在正确的位置有很好的注释。

表演技巧：

如果性能对您至关重要，那么可以考虑另一种解决方案，包括ADODB库，而不是仅仅为了获取数据而打开.CSV文件。ADODB允许您在不实际打开文件的情况下将文件内容读入Recordset对象(想想速度！)。然后，可以使用Range类的一个非常简单的方法将内容复制到电子表格- Range.CopyFromRecordset中。

你可以看到Http://vba4all.com如何在我的博客上使用ADODB的示例-ADODB一节位于本文的底部。