How to get around Run-time Error 1004

152 Views Asked by At

I am attempting copying multiply .csv files into a single .xlsx file. However, the files are rather large (400,000 rows) and after a few seconds I get a Run time Error 1004.

My code for copying the files is below. Supposedly by saving the file periodically during the write process this error is supposed to be fixed, but I'm not sure how to do that. Would it be better to just put each file in its own sheet?

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

It gives the error on the line: Cells(r, c + 1).Value = Trim(x(c))

It appears that this code is copying all the rows to the same row in the output file and that it stops when it reaches the maximum number of columns. (The .csv files are 32 columns.)

1

There are 1 best solutions below

2
On BEST ANSWER

In the end I was unable to get the code working so I switched to a different method using Query Tables. This copied the data MUCH faster (6 seconds compared to 6 minutes.)

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