我编写了一个宏，用于从网站下载包含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
我没有包含调用this 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:\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
答案 0 :(得分：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等。
答案 1 :(得分：1)
与评论中的其他建议一致： -
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") & "\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脚本运行时＆＃39;参考
添加（工具＆gt;参考＆gt;勾选＆＃39; Windows Scripting Runtime＆＃39;）oApp），然后关闭
它们DoEvents给计算机时间以运行它
可能需要，这维持了一个卫生系统。