Question

我有一个工作表“List”，其中包含我需要复制到其他工作表的数据行。在“List”的列“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

这是经济实惠的，因为你一行一行，但仍然相当快，因为你只是在名字改变时重新计算目标并重置j。

Answer 2

你可以使用：

Dictionary对象快速构建列J名称中的唯一名称列表

AutoFilter()

Range方法：

如下

    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

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

2 个答案: