复制/粘贴行到匹配的命名工作表

Question

我有一个工作表“列表”，其中包含需要复制到其他工作表的数据行。在“列表”的“J”列中，有一个名称（Matthew、Mark、Linda 等）指定该行的数据是谁。

这些名称中的每一个（总共 22 个）都有一个同名的匹配电子表格。我希望在“J”列中显示“Linda”的所有行都粘贴到工作表“Linda”，所有带有“Matthew”的行都粘贴到工作表“Matthew”等。

我在下面有一些代码，大部分都有效，但我必须为所有 22 个名称/工作表重写它。

有没有办法遍历所有工作表，粘贴具有匹配名称的行？此外，下面的代码运行速度非常慢，我正在使用需要排序和粘贴的 200 到 60,000 行的数据集，这意味着如果它在我目前正在处理的小型数据集上运行缓慢，而且只有一张纸，对于大数据集来说，它会非常缓慢。

Sub CopyMatch()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet

    Set Source = Worksheets("List")
    Set Target = Worksheets("Linda")

    j = 4     ' Start copying to row 1 in target sheet
    For Each c In Source.Range("J4:J1000")   ' Do 1000 rows
        If c = "Linda" Then
           Source.Rows(c.Row).Copy Target.Rows(j)
           j = j + 1
        End If
    Next c
End Sub

Answer 1

除非您在此处看不到的地方关闭了计算，否则每次复制一行时，Excel 都会重新计算 - 即使您的工作表不包含公式。

如果您还没有这样做，只需输入：

application.calculation=xlcalculationmanual

在开始循环之前：

application.calculation=xlcalculationautomatic

退出循环后将大大加快您的循环。对于额外的 swank，您可以使用变量来存储计算设置，然后再将其关闭并在最后恢复该设置，例如

dim lCalc as long
lCalc = application.calculation
application.calculation = xlcalculationmanual
for ... next goes here
application.calculation = lCalc

还要考虑其他设置，例如：application.screenupdating=False|True。

按您选择的名称对数据进行排序，然后按您想要的任何其他排序。这样您就可以分 22 步跳过任何尺寸的表格（因为您说您有 22 个名字）。

复制数据的方式取决于偏好和数据量。一次复制一行在内存上是经济的，并且几乎可以保证工作，但速度较慢。或者，您可以识别每个人数据的顶行和底行，并将整个块复制为单个范围，但存在超出大工作表中大块可用内存的风险。

假设您的名称列中的值对于您要检查的范围始终是 22 个名称之一，那么如果您首先按该列排序，则可以使用该列中的值来确定目的地，例如：

dim sTarget as string
dim rng as range
sTarget = ""
For Each c In Source.Range("J4:J1000") ' Do 1000 rows
    if c <> "" then ' skip empty rows
        if c <> sTarget then ' new name block
            sTarget = c
            Set Target = Worksheets(c)
            set rng = Target.cells(Target.rows.count, 10).end(xlup) ' 10="J"
            j = rng.row + 1 ' first row below last name pasted
        end if
        Source.Rows(c.Row).Copy Target.Rows(j)
        j = j + 1
    end if
Next

这很节省内存，因为您要逐行进行，但仍然相当快，因为​​您只是在名称更改时重新计算 Target 并重置 j。

Answer 2

你可以使用：

• Dictionary 对象，用于从 J 列名称中快速构建唯一名称列表

• Range 对象的AutoFilter() 方法用于过滤每个名称：

如下

    Option Explicit

    Sub CopyMatch()
        Dim c As Range, namesRng As Range
        Dim name As Variant

        With Worksheets("List") '<--| reference "List" worskheet
            Set namesRng = .Range("J4", .Cells(.Rows.count, "J").End(xlUp)) '<--| set the range of "names" in column "J" starting from row 4 down to last not empty row
        End With

        With CreateObject("Scripting.Dictionary") '<--| instance a 'Dictionary' object
            For Each c In namesRng.SpecialCells(xlCellTypeConstants, xlTextValues) '<--| loop through "names" range cells with text content only
                .item(c.Value) = c.Value '<--| build the unique list of names using dictionary key
            Next
            Set namesRng = namesRng.Resize(namesRng.Rows.count + 1).Offset(-1) '<--| resize the range of "names" to have a "header" cell (not a name to filter on) in the first row
            For Each name In .Keys '<--| loop through dictionary keys, i.e. the unique names list
                FilterNameAndCopyToWorksheet namesRng, name '<--| filter on current name and copy to corresponding worksheet
            Next
        End With '<--| release the 'Dictionary' object
    End Sub

    Sub FilterNameAndCopyToWorksheet(rangeToFilter As Range, nameToFilter As Variant)
        Dim destsht As Worksheet

        Set destsht = Worksheets(nameToFilter) '<--| set the worksheet object corresponding to passed name
        With rangeToFilter
            .AutoFilter Field:=1, Criteria1:=nameToFilter
            Intersect(.Parent.UsedRange, .Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy destsht.Cells(destsht.Rows.count, "J").End(xlUp)
            .Parent.AutoFilterMode = False
        End With
    End Sub