如何在文件夹（Excel VBA）中的所有文件上运行macros？

更新：我也发布迭代代码下面的macros。

我正在写一个macros，它将运行在一个文件夹中的所有Excel文件中，并复制具有特定标题的列，然后粘贴到一个新的工作表（标题为“ExtractedColumns”）。 我能够在一个小文件夹（四个工作簿）上运行这个macros，并成功地将数据提取到“提取的列”工作表上。 但是，当我在一个包含60个文件的文件夹（其中包括我成功的样本集中的四个文件）上运行macros时，它跳过了一些工作簿，似乎已经包装了自己 – 最后一个文件的提取列出现在开始处，从前几个文件（包括之前成功运行的示例文件）都没有出现。

有没有人有任何线索为什么下面的代码可能无法正常工作？ 我从中间切出列提取macros来在这里张贴，因为我testing了很多次 – 我在想这个问题是迭代通过文件夹的代码。 如果需要，我也可以发布实际的macros。 谢谢！

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 

这是macros：

  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

您应该通过提供正在处理的工作表来清理代码。

 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 

我永远不会使用ActiveSheet。

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

试试这个

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

我希望这个帮助。 因为我没有安装Excel，所以我无法真正在我的机器上testing它。