复制/粘贴行到匹配的命名表
我有一个工作表“列表”，其中有我需要复制到其他工作表的数据行。 在“List”的“J”栏中，有一个名字（Matthew，Mark，Linda等）指定谁是行数据。
这些名称中的每一个（共22个）都有一个匹配的电子表格，名称相同。 我希望所有在“J”栏中都是“Linda”的行可以粘贴到工作表“Linda”中，所有包含“Matthew”的行都可以粘贴到工作表“Matthew”等。
我在下面有一些代码，主要工作，但我不得不重写它的所有22名称/表。
有没有办法循环遍历所有的表格，粘贴行匹配的名称？ 另外，下面的代码工作起来非常缓慢，我使用的数据集有200到60,000行需要sorting和粘贴，这意味着如果数据集在像我目前正在使用的那样小的数据集上很慢，只有一张纸，对于大数据集来说，速度会变慢。
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 除非您将计算closures，否则我们无法在这里看到，那么每次复制一行时，Excel都将重新计算 – 即使您的工作表不包含公式。
如果你还没有这样做，简单地说：
application.calculation=xlcalculationmanual
在开始你的循环之前：
application.calculation=xlcalculationautomatic
退出循环后将大大加快你的循环。 对于额外的swank，你可以使用一个variables来存储计算设置，然后closures它，最后恢复设置，例如
dim lCalc as long lCalc = application.calculation application.calculation = xlcalculationmanual for ... next goes here application.calculation = lCalc
另外考虑其他设置，例如：application.screenupdating = False | True。
按照您select的名称对数据进行sorting，然后按照您想要的其他sorting进行sorting。 这样，你可以跳过任何大小的工作表在22个步骤（因为你说你有22个名字）。
如何复制数据取决于首选项和数据量。 一次复制一行在内存上是经济的，几乎可以保证工作，但速度较慢。 或者，您可以识别每个人的数据的顶部和底部行，并将整个块复制为一个单一范围，这样就有可能超出大型工作表中大块的可用内存。
假设name列中的值对于你检查的范围来说总是22个名字中的一个，那么如果你先按该列sorting，那么可以使用该列中的值来确定目的地，例如：
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。
你可以使用：
-
Dictionary对象来快速构buildJ列名称外的唯一名称列表 -
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, ie 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