为什么我的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

我并没有包括调用这个sub并下载和解压缩文件的主模块，因为它本身就可以完美地工作。只有当我在这里复制的sub被调用时，它才会停止工作。Filename来自主模块中定义的一个公共变量，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:Usersistvan.szaboDocuments   BasslinkAEMO RAW DATARAWRAW" & 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:UsersRontest"
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "" Then
DefPath = DefPath & ""
End If
FileNameFolder = "C:Usersistvan.szaboDocumentsBasslinkAEMO RAW DATARAWRAW" & 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:Usersistvan.szaboDocumentsBasslinkAEMO 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等

Answer 2

与评论中的其他建议一致：-

• 例如，当您使用Set WinHttpReq = Nothing处理完资源时，应该关闭这些资源。这可以避免类似于您所看到的问题的内存问题
• 还建议删除On Error Resume Next。这是隐藏错误，你很可能会错过你需要的结果。它还允许在出现错误时提供更多信息

我取了你的两个代码块，并将它们写进一个我相信在运行过程中会稳定的代码块中，并将其写到最后，运行这个代码块，让我们知道它是否解决了问题。我这样做是因为有很多小的变化，我怀疑这些变化会更稳定，并最终实现。

Sub DownloadandUnpackFile()
Dim FSO             As New FileSystemObject
Dim DteDate         As Date
Dim Fl              As File
Dim Fl_Root         As File
Dim Fldr            As Folder
Dim Fldr_Root       As Folder
Dim LngCounter      As Long
Dim LngCounter2     As Long
Dim oApp            As Object
Dim oStream         As Object
Dim oWinHttpReq     As Object
Dim RngIDs          As Range
Dim StrURL          As String
Dim StrRootURL      As String
Dim VntFile         As Variant
Dim VntFolder       As Variant
Dim VntRootFile     As Variant
Dim VntRootFolder   As Variant
Dim WkBk            As Workbook
Dim WkSht           As Worksheet
'This will speed up processing, but you might not see progress while it is working
Application.ScreenUpdating = False
'Set variables
StrRootURL = "http://www.nemweb.com.au/REPORTS/ARCHIVE/Dispatch_SCADA/PUBLIC_DISPATCHSCADA_"
'You should be a little more explicit here for clarity, refernce a worksheet
'E.g. StrID = ThisWorkbook.Worksheets("Sheet1").Range(Cells(2, 1), Cells(8, 1))
Set RngIDs = Range(Cells(2, 1), Cells(8, 1))
Set oWinHttpReq = CreateObject("Microsoft.XMLHTTP")
Set oApp = CreateObject("Shell.Application")
'Loop from 21/Feb/2015 to today
For DteDate = CDate("21/Feb/2015") To Date
StrURL = StrRootURL & Format(DteDate, "YYYYMMDD") & ".zip"
Debug.Print StrURL
oWinHttpReq.Open "GET", StrURL, False
oWinHttpReq.Send
StrURL = oWinHttpReq.ResponseBody
If oWinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write oWinHttpReq.ResponseBody
VntRootFile = Environ("UserProfile") & "DocumentsBasslinkAEMO RAW DATARAWRAW" & Format(DteDate, "YYYYMMDD") & ".zip"
oStream.SaveToFile VntRootFile
oStream.Close
Set oStream = Nothing
VntRootFolder = Environ("UserProfile") & "DocumentsBasslinkAEMO RAW DATARAWRAW" & Format(DteDate, "YYYYMMDD") & ""
FSO.CreateFolder VntRootFolder
oApp.Namespace(VntRootFolder).CopyHere oApp.Namespace(VntRootFile).Items
Set Fldr_Root = FSO.GetFolder(VntRootFolder)
'Unzip the zipped zips
For Each Fl_Root In Fldr_Root.Files
If Right(LCase(Fl_Root.Name), 4) = ".zip" Then
VntFolder = Fl_Root.ParentFolder & "" & Left(Fl_Root.Name, Len(Fl_Root.Name) - 4) & ""
FSO.CreateFolder VntFolder
VntFile = Fl_Root.Path
oApp.Namespace(VntFolder).CopyHere oApp.Namespace(VntFile).Items
Set Fldr = FSO.GetFolder(VntFolder)
For Each Fl In Fldr.Files
If Right(LCase(Fl.Name), 4) = ".csv" Then
Set WkBk = Application.Workbooks.Open(Fl.Path)
Set WkSht = WkBk.Worksheets(1)
For LngCounter = 1 To RngIDs.Rows.Count
LngCounter2 = 1
Do Until WkSht.Cells(LngCounter2, 6) = ""
If WkSht.Cells(LngCounter2, 6) = RngIDs.Cells(LngCounter, 1) Then
Debug.Print "FOUND: " & Fl.Name & ": " & WkSht.Cells(LngCounter2, 6).Address
End If
LngCounter2 = LngCounter2 + 1
Loop
Next
Set WkSht = Nothing
WkBk.Close 0
Set WkBk = Nothing
End If
DoEvents
Next
Set Fldr = Nothing
End If
Next
Fldr_Root.Delete True
Set Fldr_Root = Nothing
FSO.DeleteFile VntRootFile, True
End If
DoEvents
Next
Set oApp = Nothing
Set oWinHttpReq = Nothing
Set RngIDs = Nothing
Application.ScreenUpdating = True
End Sub

我所做的更改：-

• 我使用早期绑定FileSystemObject只是为了让它更容易写。您将需要"Windows Scripting Runtime"引用已添加("工具">"引用">勾选"Windows脚本运行时")
• 我把日期迭代为一个循环，而不是三个循环用作日期的字符串
• 我将ID设置为一个范围，并注意到一个变体
• 我打开过一次引用，重用它们(即oApp)，然后关闭他们
• 我添加DoEvents是为了让计算机有时间运行它可能需要，这就维持了一个卫生系统
• 我使用Debug.Print将信息添加到即时窗口的消息框，但你真的应该在一个单独的列表中列出发现工作表，(debug.print有一个大小限制，所以您最终只能当其他结果被截断时，看到X的结果数