从动态范围中动态提取数据行

Question

我有一个电子表格，其中包含与食品成分有关的大量原始数据表。然后必须针对新成分对数据进行分类，清除旧数据并填充新数据。

电子表格最初的设置是，用户必须手动点击“清除数据”按钮，然后点击每个标签上的“提取新数据”按钮。这本工作手册有几十个标签，并且随着新成分的添加而不断增长。

我已经设置了一个宏，它通过一次运行就可以遍历并清除所有数据，但是我无法让工作表动态排序并将数据提取到每个单独的工作表。我可以通过硬编码每个单独选项卡的名称来暴力破解它，但这需要在每次必须添加新成分时更新宏。我希望让它尽可能动态化，并感觉我很接近。

每张配料表在“A1”中都有该配料对应的物料编号，在搜索时用作标识符。

我需要电子表格的整体行为是这样的： 1.) 将活动工作表的 A1 范围内的材料编号与“原始数据”工作表上的第一个材料编号进行比较。

2.) 如果活动表的物料编号与当前行中的物料号匹配，则将原始数据表上的整行复制到活动表。

3.)如果这些单元格不匹配，则移动到列中的下一行并重复直到列的末尾。

4.) 激活工作簿中的下一张工作表并重复该过程，直到所有工作表都循环完成。

以下是我目前拥有的代码：

Sub PullNewData()

Dim wks As Worksheet
Set i = Sheets("Raw Data")
Set e = ActiveSheet
Dim d
Dim j
d = 20
j = 2

For Each wks In ActiveWorkbook.Worksheets

If wks.Name <> "Ingredient List" Then

    If wks.Name <> "Raw Data" Then

        If wks.Name <> "Instructions" Then

            wks.Activate

            For Each Cell In i.Range("B2:B10000")

            If i.Range("B" & j) = e.Range("A1") Then
            d = d + 1
            e.Rows(d).Value = i.Rows(j).Value

            End If
            j = j + 1
            Next Cell

        d = 20
        j = 2

        End If

    End If

End If

Next wks


End Sub

此代码适用于激活的任何工作表（提取正确的数据），然后循环浏览其余工作表，而不复制任何这些工作表的数据。谁能告诉我为什么这段代码没有复制到最初未激活的工作表中？

PS 开头附近的三重 IF 语句用于排除三张工作表的数据排序。

Answer 1

这不依赖于 ActiveSheet

---

Option Explicit

Public Sub PullNewData2()

    Const RAW_COL = 2           'B column in "Raw Data" ws
    Const THIS_LAST_ROW = 20    'last used row on current ws

    Dim ws As Worksheet, wsRaw As Worksheet, urRaw As Variant, r As Long

    Set wsRaw = ThisWorkbook.Worksheets("Raw Data")
    urRaw = wsRaw.UsedRange

    Dim xclude As Variant, cellA1 As String, lr As Long, foundRow As Long
    xclude = Array("Ingredient List", "Raw Data", "Instructions")

    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> xclude(0) And ws.Name <> xclude(1) And ws.Name <> xclude(2) Then
            foundRow = THIS_LAST_ROW
            cellA1 = Trim$(ws.Range("A1").Value2)
            For r = 2 To UBound(urRaw)
                If urRaw(r, RAW_COL) = cellA1 Then
                    foundRow = foundRow + 1
                    ws.Rows(foundRow).Value = wsRaw.Rows(r).Value
                End If
            Next r
        End If
    Next ws
End Sub

---

一种更快的方法是使用自动筛选

---

Option Explicit

Sub PullNewData3()
    Const RAW_COL = 2       'B column in "Raw Data" ws
    Const FIRST_ROW = 21

    Dim ws As Worksheet, wsRaw As Worksheet, xclude As Variant, cellA1 As String

    Set wsRaw = ThisWorkbook.Worksheets("Raw Data")
    xclude = Array("Ingredient List", "Raw Data", "Instructions")
    optimizeXL True
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> xclude(0) And ws.Name <> xclude(1) And ws.Name <> xclude(2) Then
            cellA1 = Trim$(ws.Range("A1").Value2)

            With wsRaw.UsedRange
                If wsRaw.AutoFilterMode Then .AutoFilter    'clear filters
                .AutoFilter Field:=RAW_COL, Criteria1:=cellA1
                .Copy ws.Cells(FIRST_ROW, 1)
                ws.Cells(FIRST_ROW, 1).EntireRow.Delete     'if 1st row contains Headers
                .AutoFilter  'clear filter
            End With

        End If
    Next ws
    optimizeXL False
End Sub

Public Sub optimizeXL(Optional ByVal settingsOff As Boolean = True)
    With Application
        .ScreenUpdating = Not settingsOff
        .Calculation = IIf(settingsOff, xlCalculationManual, xlCalculationAutomatic)
        .EnableEvents = Not settingsOff
    End With
End Sub