将表格行复制到具有多个条件的新表中 - 仅复制第一行？

我有一个项目，我希望你们中的一些人能帮我解决我要出错的地方。这里的独家新闻：将表格行复制到具有多个条件的新表中 - 仅复制第一行？

我有一个Excel工作表，其中包含大量的数据表。我需要根据多个条件复制数据行并将其粘贴到另一个工作表中的另一个表中。第二个表应该扩展以适应无数行信息。像这样的东西（在Excel假设这些表）：

| A | B | C | D | 
|1 |Name^ |Fruit^ |Amount^ |Strata^ | 
|2 |Mary  |Apples |300  |Sand  | 
|3 |Dean  |Oranges |200  |Gravel | 
|4 |Mary  |Bananas |300  |Sand  | 
|5 |Sam  |Oranges |200  |Loam  | 
|6 |Mary  |Oranges |200  |Sand  | 
|7 |Dean  |Apples |500  |Loam  |

如果行包含玛丽在第一列和第三列300，该行应该被复制到新表中不同的工作表这将那么看起来像：

| A | B | C | D | 
|1 |Name^ |Fruit^ |Amount^ |Strata^ | 
|2 |Mary  |Apples |300  |Sand  | 
|3 |Mary  |Bananas |300  |Sand  |

我遇到的问题是，我可以得到行复制，但他们这样做下面的第二个表，或者我能办到的数据粘贴到第一行新的桌子。代码迄今是：

Public Sub CopyRows() 
    ' Select starting sheet with data table 
    Sheets("Full data").Select 

    ' loop through all rows 
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row 
    For x = 2 To FinalRow 
     ThisValue = Cells(x, 8).Value 
     ' Set filtering criteria and copy matching cells 
     If Cells(x, 8) = "PHONE" And Cells(x, 14) = "v" Then 
      Cells(x, 1).Resize(1, 33).Copy 
      ' Select sheet where second table is located 
      Sheets("By Phone, Verified").Select 
      ' Select the second table 
      Range("Table2[Company]").Select 
      ListObject = Cells(Rows.Count, 3).End(xlUp).Row + 1 
      ' paste the rows of data 
      ActiveSheet.Paste 
     End If 
    Next x 
End Sub

第二个表只有一个头和一个行开始，并且这两个表在其片材的第3行开始。

任何想法如何可以将复制的数据到第二个表中？让我知道是否需要更多的澄清。

来源

2016-11-17 NicCio

不知道你的全表结构，我猜想最后的ActiveSheet.Paste是反复粘贴新的行。

尝试在VB编辑器中使用F8逐步运行宏，并观察选定内容以及粘贴位置。

两个建议;

对于较小的数据集使用for i循环，试着改变你的paste命令的insert使新行的结果表的顶部增加。
对于较大的数据集避免使用循环。而是使用过滤器来选择所需的所有行，复制过滤的结果并粘贴它们。

根据经验，循环方法更容易编写，但对大型数据集的处理速度较慢。我会建议类似的;

'Clear any existing filters from Stats 
Sheets("Full Data").Select 

If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilter.Sort.SortFields.Clear 
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False 


'Apply the filter(s) 
'Range references should be absolute $A$1:$Z$26 
'Field refers to the column number within that range 
'Find non-blank columns with Criteria "<>" 
ActiveSheet.Range("<<your source range>>").AutoFilter Field:=1, Criteria1:="Mary" 
ActiveSheet.Range("<<your source range>>").AutoFilter Field:=3, Criteria1:="300" 

'Select and copy the rows 
'Use A1:D1 to include headers or A2:D2 to exclude 
Range("A1:D1").Select 
Range(Selection, Selection.End(xlDown)).Select 
Selection.Copy 

'Paste into your results 

'Remember to come back and clear the filters afterwards 
Sheets("Full Data").Select 

If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilter.Sort.SortFields.Clear 
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False

来源

2016-11-17 21:45:07 CJC

更新了示例代码 – CJC

感谢CJC，我发现代码：

Public Sub CopyRows() 
    Sheets("Full data").Select 
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row 
    For x = 2 To FinalRow 
    If Cells(x, 8) = "PHONE" And Cells(x, 14) = "v" Then 
    Cells(x, 1).Resize(1, 33).Copy 
     Sheets("By Phone, Verified").Select 
     NextRow = Cells(Rows.Count, 3).End(xlUp).Row + 1 
     Cells(NextRow, 1).Select 
     ActiveSheet.Paste 
     Sheets("Full data").Select 
    End If 
Next x  
End Sub

我想要做什么，但不会行粘贴到表中。你绝对正确，它非常缓慢，超过5K行被分成大约10张工作表的不同方式，这将是一整天的事件！如果有更好的方法来做到这一点，我会全力以赴。

来源

2016-11-17 23:02:22 NicCio

将表格行复制到具有多个条件的新表中 - 仅复制第一行？

回答

相关问题