如何绕过运行时错误 1004

Question

我正在尝试将.csv文件复制到单个.xlsx文件中。但是，这些文件相当大（400,000 行），几秒钟后我得到运行时错误 1004。

我复制文件的代码如下。据说通过在写入过程中定期保存文件，应该修复此错误，但我不确定该怎么做。将每个文件放在自己的工作表中会更好吗？

Dim x As Variant
Dim Cnt As Long, r As Long, c As Long
FilePath = Application.ActiveWorkbook.Path & ""
file = Dir(FilePath & "*.csv")
Do While Len(file) > 0
    Cnt = Cnt + 1
    r = Cells(Rows.Count, "A").End(xlUp).Row + 1
    Open FilePath & file For Input As #1     
        Do Until EOF(1)
            Line Input #1, strData
            x = Split(strData, ",")
            For c = 0 To UBound(x)
                Cells(r, c + 1).Value = Trim(x(c))
            Next c
            r = r + 1
        Loop
    Close #1
    file = Dir
Loop
If Cnt = 0 Then MsgBox "No CSV files found...", vbExclamation

它给出了以下行的错误：Cells(r, c + 1).Value = Trim(x(c))

此代码似乎正在将所有行复制到输出文件中的同一行，并且在达到最大列数时停止。（.csv文件为 32 列。

Answer 1

最后我

无法让代码工作，所以我使用查询表切换到不同的方法。这复制数据的速度要快得多（6 秒与 6 分钟相比）。

i = 0
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(Application.ActiveWorkbook.Path)
For Each objFile In objFolder.Files
    If Right$(objFile, 3) = "csv" Then
        Sheets(i + 1).Cells.Clear 'remove for final release possibly?
        With Sheets(i + 1).QueryTables.Add(Connection:="TEXT;" + objFile, Destination:=Sheets(i + 1).Range("A1"))
            .Name = objFile
            .FieldNames = True
            .RowNumbers = False
            .RefreshOnFileOpen = False
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 437
            .TextFileStartRow = 3
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileCommaDelimiter = True
            .Refresh BackgroundQuery:=False
            .RefreshStyle = xlOverwriteCells
        End With
        i = i + 1
    End If
    Set objFile = Nothing
Next objFile