Question

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

目前，我的宏看起来像这样：

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

在我使用的主要功能中：

For each wb in Workbooks

    PerLineItem

Next wb

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

P.S我知道可能有一种更简单的方法来编写所有这些代码，但我不知道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

P.S我决定废弃创建另一个工作表并在“报告”

中工作

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
顺便说一句，希望这有帮助。

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

1 个答案: