Wie Makro für alle Dateien in einem Ordner (Excel VBA) ausführen?

Question

Update: Ich poste auch das Makro unter dem Iterationscode.

Ich schreibe ein Makro, das auf alle Excel-Dateien in einem Ordner ausgeführt wird und Spalten mit bestimmten Kopfzeilen kopiert, dann fügen Sie es in ein neues Blatt (mit dem Titel "ExtractedColumns"). Ich konnte dieses Makro in einem kleinen Ordner (vier Arbeitsmappen) ausführen und die Daten erfolgreich auf dem Blatt Extracted Columns abrufen. Als ich jedoch das Makro auf einen Ordner mit 60 Dateien (darunter die vier Dateien aus meinem erfolgreichen Beispielsatz) ausführte, übersprang es einige Arbeitsmappen und scheint sich selbst umgebrochen zu haben - die extrahierten Spalten der letzten Datei erscheinen am Anfang und Spalten von den ersten Dateien (einschließlich der Beispieldateien, die früher erfolgreich ausgeführt wurden), wurden überhaupt nicht angezeigt.

Hat jemand eine Ahnung, warum der folgende Code nicht funktioniert? Ich habe das spaltenextrahierende Makro von der Mitte abgeschnitten, um es hier zu posten, weil ich das viele Male getestet habe - ich denke, das Problem ist der Code, der durch den Ordner iteriert. Bei Bedarf kann ich auch das eigentliche Makro posten. Vielen Dank!

Sub AllFiles() 
Dim folderPath As String 
Dim filename As String 
Dim wb As Workbook 

folderPath = 'I put the path name here 

If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\" 

filename = Dir(folderPath & "*.xls") 
Do While filename <> "" 
    Application.ScreenUpdating = False 
    Set wb = Workbooks.Open(folderPath & filename) 

    'Macro from below goes here 

    Workbooks("ExtractedColumns").Worksheets("Sheet1").Cells(n, 1).Value = filename 
    wb.Close 
    filename = Dir 
Loop 
Application.ScreenUpdating = True 
End Sub 

Hier ist das Makro:

Dim curr As Range 
Dim cell As Range 
Dim lastRow As Variant 
Dim n As Long 
Dim found As Boolean 
Dim FirstRow As Range 

found = False 

For i = 3 To 30 
    If Not IsEmpty(Cells(i, "C")) Then 
     Exit For 
    End If 
Next 

    For Each curr In Range("A" & i, "Z" & i) 
     If InStr(1, curr.Value, "Protein name", vbTextCompare) > 0 Or InStr(1, curr.Value, "description", vbTextCompare) > 0 Or InStr(1, curr.Value, "Common name", vbTextCompare) > 0 Then 
      Range(curr.Offset(1), Cells(Rows.Count, curr.Column).End(xlUp)).Copy Destination:=Workbooks("ExtractedColumns (version 2)").Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) 
      found = True 
      Exit For 
     End If 
    Next 

    If Not found Then 
     For Each curr In Range("A" & i, "Z" & i) 
      If InStr(1, curr.Value, "protein", vbTextCompare) > 0 Then 
       Range(curr.Offset(1), Cells(Rows.Count, curr.Column).End(xlUp)).Copy Destination:=Workbooks("ExtractedColumns").Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) 
       Exit For 
      End If 
     Next 

    End If 
For Each curr In Range("A" & i, "Z" & i) 
     If InStr(1, curr.Value, "accession", vbTextCompare) > 0 Or InStr(1, curr.Value, "Uniprot", vbTextCompare) > 0 Or InStr(1, curr.Value, "IPI") > 0 Then 
      Range(curr.Offset(1), Cells(Rows.Count, curr.Column).End(xlUp)).Copy Destination:=Workbooks("ExtractedColumns").Sheets("Sheet1").Cells(Rows.Count, "E").End(xlUp).Offset(1, 0) 
      found = True 
      Exit For 
     End If 
    Next 

For Each curr In Range("A" & i, "Z" & i) 
     If (InStr(1, curr.Value, "residue", vbTextCompare) > 0 Or curr.Value = "Position" Or curr.Value = "Positions" Or InStr(1, curr.Value, "Site", vbTextCompare) > 0) And Not InStr(1, curr.Value, "ERK") > 0 Then 
      Range(curr.Offset(1), Cells(Rows.Count, curr.Column).End(xlUp)).Copy Destination:=Workbooks("ExtractedColumns").Sheets("Sheet1").Cells(Rows.Count, "G").End(xlUp).Offset(1, 0) 
      Exit For 
     End If 
Next 

    'puts dashes in any blank cells in the columns 
    n = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row 
    For Each curr In Workbooks("ExtractedColumns").Sheets("Sheet1").Range("D2:D" & n) 
     If curr.Value = "" Then curr.Value = " - " 
    Next 
    For Each curr In Workbooks("ExtractedColumns").Sheets("Sheet1").Range("E2:E" & n) 
     If curr.Value = "" Then curr.Value = " - " 
    Next 
    For Each curr In Workbooks("ExtractedColumns").Sheets("Sheet1").Range("G2:G" & n) 
     If curr.Value = "" Then curr.Value = " - " 
    Next 

Answer 1

Sie sollten und Ihr Code aufzuräumen, indem das Arbeitsblatt, das Sie arbeiten.

set ws = wb.Sheets(1) 
with ws 
    For Each curr In .Range("A" & i, "Z" & i) 
     If InStr(1, curr.Value, "Protein name", vbTextCompare) > 0 Or InStr(1, curr.Value, "description", vbTextCompare) > 0 Or InStr(1, curr.Value, "Common name", vbTextCompare) > 0 Then 
      .Range(curr.Offset(1), .Cells(.Rows.Count, curr.Column).End(xlUp)).Copy Destination:=Workbooks("ExtractedColumns (version 2)").Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) 
      found = True 
      Exit For 
     End If 
    Next 
end with 

Ich würde ActiveSheet nie verwenden.

n = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row 

Versuchen Sie stattdessen

lastRow = ws.Cells(ws.Rows.Count,"D").End(xlUp).Row 

ich diese Hilfe hoffen. Ich kann es nicht wirklich auf meinem Computer testen, da ich Excel nicht installiert habe.