excel - 为什么我的 VBA 宏在打开和关闭数百个 CSV 文件后停止？

Question

我编写了一个宏，用于从网站下载包含 CSV 的 zip 文件。下载和解压缩进展顺利，但是当我尝试循环遍历 CSV 来搜索特定字符串的出现时，宏在打开大约一千个后就退出了。没有错误消息，它只是停止工作，将其处理的最后一个 CSV 保持打开状态。

这是我的代码:

Sub OpenSearch()
Dim ROW, j As Integer

Workbooks.Open Filename:=FileNameFolder & FileListCSV(i)

For j = 1 To 7
    ROW = 3
    Do Until IsEmpty(Cells(ROW, 6))
    If Cells(ROW, 6) = WantedID(j, 1) Then
        MsgBox "WE HAVE A MATCH!"
    End If
    ROW = ROW + 1
    Loop
Next j

Workbooks(FileListCSV(i)).Close False
Kill FileNameFolder & FileListCSV(i)

End Sub

我没有包含调用此子模块并下载和解压缩文件的主模块，因为它本身就可以完美工作。仅当我在此处复制的子程序被调用时，它才会停止工作。文件名来自主模块中定义的公共(public)变量，WantedID 包含我需要在 CSV 中查找的字符串。

我尝试将Application.Wait放在第一行，但没有解决问题。此外，宏的到达程度是完全随机的。打开和关闭相同数量的 CSV 后，它永远不会停止。

更新:这是用于下载和解压缩的代码(父子)。这不是我自己想出来的，而是从我不记得的在线来源复制的:

Public FileListCSV(1 To 288) As String
Public i As Integer
Public FileNameFolder As Variant
Public WantedID As Variant


Sub DownloadandUnpackFile()

Dim myURL As String
Dim YearNUM As Integer
Dim MonthNUM As Integer
Dim StarMonth, EndMonth As Integer
Dim DayNUM As Integer
Dim YearSTR As String
Dim MonthSTR As String
Dim DaySTR As String
Dim FixURL As String
Dim TargetFileName As String

Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim DefPath As String
Dim strDate As String

Dim StrFile As String
Dim FileList(1 To 288) As String

Application.ScreenUpdating = False
FixURL = "http://www.nemweb.com.au/REPORTS/ARCHIVE/Dispatch_SCADA PUBLIC_DISPATCHSCADA_"
WantedID = Range(Cells(2, 1), Cells(8, 1))

YearNUM = 2016
StarMonth = 12
EndMonth = 12

For YearNUM = 2015 To 2016
    For MonthNUM = StarMonth To EndMonth

        For DayNUM = 1 To 31
            YearSTR = CStr(YearNUM)
            If MonthNUM < 10 Then
                MonthSTR = "0" & CStr(MonthNUM)
            Else:
                MonthSTR = CStr(MonthNUM)
            End If

            If DayNUM < 10 Then
                DaySTR = "0" & CStr(DayNUM)
            Else:
                DaySTR = CStr(DayNUM)
            End If

            myURL = FixURL & YearSTR & MonthSTR & DaySTR & ".zip"
            Cells(1, 1) = myURL
            Dim WinHttpReq As Object
            Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
            WinHttpReq.Open "GET", myURL, False
            WinHttpReq.Send

            myURL = WinHttpReq.ResponseBody
            If WinHttpReq.Status = 200 Then
                Set oStream = CreateObject("ADODB.Stream")
                oStream.Open
                oStream.Type = 1
                oStream.Write WinHttpReq.ResponseBody
                TargetFileName = "C:\Users\istvan.szabo\Documents   \Basslink\AEMO RAW DATA\RAWRAW\" & YearSTR & MonthSTR & DaySTR & ".zip"
                oStream.SaveToFile (TargetFileName)
                oStream.Close
             End If

        'try unzippin'

            Fname = TargetFileName
                If Fname = False Then
        'Do nothing
            Else
                'Root folder for the new folder.
                'You can also use DefPath = "C:\Users\Ron\test\"
                 DefPath = Application.DefaultFilePath
                If Right(DefPath, 1) <> "\" Then
                    DefPath = DefPath & "\"
                 End If

                FileNameFolder = "C:\Users\istvan.szabo\Documents\Basslink\AEMO RAW DATA\RAWRAW\" & YearSTR & MonthSTR & DaySTR
                'Make the normal folder in DefPath
                MkDir FileNameFolder

                'Extract the files into the newly created folder
                 Set oApp = CreateObject("Shell.Application")

                 oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items

                On Error Resume Next
                Set FSO = CreateObject("scripting.filesystemobject")
                FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
                i = 1
                StrFile = Dir(FileNameFolder & "\")
                    Do While Len(StrFile) > 0
                        FileList(i) = FileNameFolder & "\" & StrFile
                        FileListCSV(i) = Left(StrFile, Len(StrFile) - 3) & "csv"
                        StrFile = Dir
                         i = i + 1
                     Loop
                 'unzip the unzipped
                For i = 1 To 288
                     Fname = FileList(i)
                     If Fname = False Then
                     'Do nothing
                    Else:
                        DefPath = Application.DefaultFilePath
                        If Right(DefPath, 1) <> "\" Then
                            DefPath = DefPath & "\"
                         End If
                         FileNameFolder = "C:\Users\istvan.szabo\Documents\Basslink\AEMO RAW DATA\"
                         Set oApp = CreateObject("Shell.Application")
                         oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
                         On Error Resume Next
                        Set FSO = CreateObject("scripting.filesystemobject")
                        FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
                        Call OpenSearch
                    End If
                Next i
            End If

        Next DayNUM
    Next MonthNUM
    StarMonth = 1
    EndMonth = 5
 Next YearNUM

 Application.ScreenUpdating = True
 End Sub

Answer 1

您可以在不打开文件的情况下检查该文件。这会节省您的时间和资源。这是我将使用的代码的快速绘制:

Sub OpenSearch()

Dim ROW, j As Integer
Dim fileID
Dim buf As String
Dim tmp As Variant

Open FileNameFolder & FileListCSV(i) For Input As #1

For j = 1 To 7

    ROW = 3

    Do Until EOF(1)

        Line Input #1, buf

        'Remove double quotes
        buf = Replace(buf, """", "")

        'Split line to a array
        tmp = Split(buf, ",")

        '5 is the 6th column in excel tmp index starts with 0
        fileID = tmp(5)

        If fileID = WantedID(j, 1) Then
            MsgBox "WE HAVE A MATCH!"
        End If

    ROW = ROW + 1

    Loop

Next j

Close #1

Kill FileNameFolder & FileListCSV(i)

End Sub

编辑:还要尝试添加资源清理代码，例如:Set WinHttpReq = Nothing、Set oStream = Nothing 等。