Warum stoppt mein VBA-Makro nach dem Öffnen und Schließen einiger hundert CSV-Dateien?

Question

Ich habe ein Makro geschrieben, das zip-Dateien mit CSVs von einer Website herunterlädt. Das Herunterladen und Dekomprimieren geht perfekt, aber wenn ich versuche, die CSVs zu durchlaufen, die nach dem Auftreten einer bestimmten Zeichenfolge suchen, wird das Makro nach dem Öffnen von etwa tausend beendet. Es gibt keine Fehlermeldung, es funktioniert einfach nicht mehr und es bleibt die letzte CSV-Datei geöffnet.

Hier ist mein Code:

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 

Ich habe nicht das Hauptmodul enthalten, das diese Unter und Downloads ruft und packt die Dateien, weil auf seine eigene, die perfekt funktioniert. Es funktioniert nur dann nicht mehr, wenn das Sub-Objekt, das ich kopiert habe, aufgerufen wird. Der Dateiname stammt von einer öffentlichen Variablen, die im Hauptmodul definiert ist, WantedID enthält die Strings, die ich in den CSVs finden muss.

Ich habe versucht, Application.Wait in die erste Zeile zu setzen, aber es hat das Problem nicht gelöst. Auch wie weit das Makro kommt, ist völlig zufällig. Es stoppt nie, nachdem die gleiche Anzahl von CSVs geöffnet und geschlossen wurde.

UPDATE: Hier ist der Code (Elternteil) für das Herunterladen und Entpacken. Ich bin nicht gekommen mit diesem auf meiner eigenen, aber es aus einer Online-Quelle kopiert ich mich nicht erinnern kann:

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

Sie könnten die Datei überprüfen, ohne sie zu öffnen. Das würde Ihnen Zeit und Ressourcen sparen. Hier ist ein kurzer Zug des Code würde ich verwenden:

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 

EDIT: auch versuchen, eine Ressource Bereinigungscode hinzuzufügen, zum Beispiel: Set WinHttpReq = Nothing, Set oStream = Nothing usw.

Answer 2

Im Einklang mit anderen Tipps in den Kommentaren: -

Sie sollten schließen von Ressourcen, wenn Sie mit ihnen fertig sind mit Set WinHttpReq = Nothing zum Beispiel. Dies kann Speicherprobleme vermeiden, die dem angezeigten Problem ähneln.

Es ist auch ratsam, On Error Resume Next zu entfernen. Dadurch werden Fehler ausgeblendet und möglicherweise fehlen Ihnen Ergebnisse, die Sie benötigen. Es würde auch mehr Informationen bei Fehlern ermöglichen.

Ich nahm Ihre zwei Codeblöcke und schrieb sie in eine, die ich glaube, wird während des Laufens stabil sein und es bis zum Ende machen, Führen Sie dies aus und lassen Sie uns wissen, ob es das Problem gelöst hat. Ich habe es so gemacht, denn es gab viele kleine Änderungen, die in Richtung auf etwas gingen, von dem ich annehme, dass es stabiler wird und es bis zum Ende schafft.

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 

Änderungen ich gemacht habe: -

• Ich benutzte die frühe Bindung an FileSystemObject einfach es einfacher nachholen zu schreiben. Sie werden die ‚Windows Scripting Runtime‘ Referenz müssen hinzugefügt (Tools> Referenzen> tick ‚Windows Scripting Runtime‘)
• ich durch Daten als einzelne iteriert eher dann drei Schleifen von Strings als Datum Arbeits
• I setze IDs auf einen Bereich und notiere eine Variante
• Ich öffnete Referenzen einmal, benutze sie wieder (d. hoApp), und dann schließen sie
• Ich habe DoEvents hinzugefügt, um dem Computer Zeit zu geben, etwas zu laufen, das es möglicherweise braucht, dies unterhält ein Gesundheitssystem.
• I Debug.Print Informationen zum sofortigen Fenster statt von msgbox hinzuzufügen verwendet, aber Sie sollten wirklich die Funde aus in einem separaten Arbeitsblatt auflisten (debug.print hat eine Größenbeschränkung, so dass Sie nur können am Ende zu sehen, X Anzahl der Ergebnisse als andere abgeschnitten wird.