如何循环执行每个中相同function的工作簿？

我一直在试图创build一个macros，从几个打开的工作簿中提取特定的单元格数据，这些工作簿都包含一个名为（“Report_Final”）的特定工作表

目前，我的macros像这样：

Sub PerLineItem() 'Main function i'm trying to call for each open workbook Dim wb As Workbook Dim ws, ws2 As Worksheet Dim i, j, k, x, rng As Integer Dim temp_total As Double Dim mat_name1, mat_name2 As String i = 2 j = 2 k = 2 rng = 0 Application.ScreenUpdating = False Set wb = ActiveWorkbook Sheets.Add Set ws = ActiveSheet 'Intermediate sheet to filter only columns 2, 11 & 18' ws.Name = "Report" Cells(1, 2) = "WBS" Cells(1, 3) = "Material" Cells(1, 4) = "Sell Total Price" Sheets("zero250").Select Do While Cells(i, 2) <> "" rng = rng + 1 i = i + 1 Loop 'Copy and paste columns 2, 11, 18 to 2, 3, 4 in the new sheet("Report") Do While j < rng If ((Right(Cells(j, 2), 3) = "RTN") Or (Right(Cells(j, 2), 3) = "NRT")) Then Union(Cells(j, 2), Cells(j, 11), Cells(j, 18)).Copy Sheets("Report").Select Union(Cells(k, 2), Cells(k, 3), Cells(k, 3)).Select ActiveSheet.Paste Sheets("zero250").Select k = k + 1 End If j = j + 1 Loop 'Create new sheet to group up identical named materials and sum the value up Sheets.Add Set ws2 = ActiveSheet 'The debugger always points to the below line "name is already taken" since it is being run in the same workbook ws2.Name = "Report_Final" Sheets("Report").Select i = 2 j = 2 k = 2 x = 2 rng = 1 Do While Cells(i, 2) <> "" rng = rng + 1 i = i + 1 Loop 'deletes identicals names and sums the value up, puts the values onto sheet("Report_final") Do While j <= rng If Cells(j, 3) <> "" Then mat_name1 = Cells(j, 3).Value temp_total = Cells(j, 4).Value For x = j To rng mat_name2 = Cells(x + 1, 3).Value If mat_name2 = mat_name1 Then temp_total = temp_total + Cells(x + 1, 4).Value Rows(x + 1).ClearContents End If Next x Sheets("Report_Final").Select Cells(k, 2) = mat_name1 Cells(k, 3) = temp_total Sheets("Report").Select Rows(j).ClearContents k = k + 1 j = j + 1 Else j = j + 1 End If Loop 'Labels the new columns in "Report_Final" and calculates the grand total ws2.Select Cells(1, 1).Value = wb.Name Cells(1, 2).Value = "Material" Cells(1, 3).Value = "Sell Total Price" Cells(k, 3).Value = Application.Sum(Range(Cells(2, 3), Cells(k, 3))) Application.DisplayAlerts = False 'Deletes intermediate sheet "Report" Sheets("Report").Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub 

在我使用的主要function：

 For each wb in Workbooks PerLineItem Next wb 

它不会为每个打开的工作簿调用PerLineItem，而是尝试在同一个工作簿上再次执行该函数。

PS我知道可能有一个更简单的方法来编写所有这些代码，但我不知道以前的知识VBA 🙁

编辑：嗨，所以我用你的代码进行了一些修改，它工作正常！ 但现在当我添加下一部分，它只能通过上一个工作簿，因为计数器k似乎并没有循环的早期工作簿

 '~~> cleaning up the sheet still goes here With wb.Sheets("Report") rng2 = .Range("B" & .Rows.Count).End(xlUp).Row MsgBox rng2 Do While j <= rng2 If Cells(j, 3) <> "" Then mat_name1 = .Cells(j, 3).Value temp_total = .Cells(j, 4).Value For x = j To rng2 mat_name2 = .Cells(x + 1, 3).Value If mat_name2 = mat_name1 Then temp_total = temp_total + .Cells(x + 1, 4).Value .Rows(x + 1).ClearContents End If Next x .Rows(j).ClearContents .Cells(k, 2) = mat_name1 .Cells(k, 3) = temp_total k = k + 1 j = j + 1 Else j = j + 1 End If Loop MsgBox k End With With Application .ScreenUpdating = True .DisplayAlerts = True End With 

PS我决定废除创build另一个工作表，并在“报告”

Answer 1

尝试这个：

 Dim wb As Workbook For Each wb in Workbooks If wb.Name <> Thisworkbook.Name Then PerLineItem wb End If Next 

编辑1：你需要适应你的这个子

 Private Sub PerLineItem(wb As Workbook) Dim ws As Worksheet, ws2 As Worksheet Dim i As Long, j As Long, k As Long, x As Long, rng As Long Dim temp_total As Double Dim mat_name1 As string, mat_name2 As String i = 2: j = 2: k = 2: rng = 0 With Application .ScreenUpdating = False .DisplayAlerts = False End With '~~> Improve initializing ws Set ws = wb.Sheets.Add(wb.Sheets(1)) ws.Name = "Report" '~~> Directly work on your object; You can also use the commented lines With ws .Cells(1, 2) = "WBS" '.Range("B1") = "WBS" .Cells(1, 3) = "Material" '.Range("C1") = "Material" .Cells(1, 4) = "Sell Total Price" '.Range("D1") = "Sell Total Price" End With '~~> Same with the other worksheet With wb.Sheets("zero250") rng = .Range("B" & .Rows.Count).End(xlUp).Row .AutoFilterMode = False .Range("B1:B" & rng).AutoFilter 1, "=*RTN*", xlOr, "=*NRT*" .Range("B1:B" & rng).Offset(1,0).SpecialCells(xlCellTypeVisisble).Copy _ ws.Range("B" & ws.Rows.Count).End(xlup).Offset(1,0) End With '~~> cleaning up the sheet still goes here End Sub 

以上代码与您的代码等同于生成报告表。
你能继续吗？ :)我用完了时间。 ，p
顺便说一句，希望这有助于。