为什么打开和closures几百个CSV文件后，我的VBAmacros停止？
我写了一个macros，从网站下载包含CSV的zip文件。 下载和解压缩是完美的，但是当我试图循环search一个特定string的CSV时，macros只是在打开大约一千之后退出。 没有错误消息，它只是停止工作，保持打开最后一个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 我没有包含调用这个子文件的主要模块，并且下载和解压文件，因为它本身就是完美的。 只有当我在这里复制的子被调用时，它才会停止工作。 Filename来自主模块中定义的公共variables，WantedID包含我需要在CSV中find的string。
我试图把Application.Wait放在第一行，但没有解决问题。 macros得多远也是完全随机的。 它在打开和closures相同数量的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
您可以在不打开的情况下检查文件。 这将节省您的时间和资源。 这是我将使用的代码的一个快速绘制：
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等
根据评论中的其他build议：
- 例如，当你完成
Set WinHttpReq = Nothing时，你应该closures资源。 这可以避免类似于您所看到的问题的内存问题。 - 还build议删除
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 'Eg 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") & "\Documents\Basslink\AEMO RAW DATA\RAWRAW\" & Format(DteDate, "YYYYMMDD") & ".zip" oStream.SaveToFile VntRootFile oStream.Close Set oStream = Nothing VntRootFolder = Environ("UserProfile") & "\Documents\Basslink\AEMO RAW DATA\RAWRAW\" & 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脚本运行时”参考（工具>参考>勾选“Windows脚本运行时”） - 我把date作为一个循环迭代，而不是三个string作为date
- 我将ID设置为一个范围并注意一个变体
- 我打开引用一次，重用它们（即
oApp），然后closures它们 - 我添加了
DoEvents，让时间回到电脑运行任何可能需要的东西，这维护着一个健康系统。 - 我使用Debug.Print将信息添加到即时窗口而不是msgbox，但是您应该将查找结果列在单独的工作表中（debug.print的大小限制，因此最终只能看到X个结果被截断。