將表格行復制到具有多個條件的新表中 - 僅複製第一行？

我有一個項目，我希望你們中的一些人能幫我解決我要出錯的地方。這裏的獨家新聞：將表格行復制到具有多個條件的新表中 - 僅複製第一行？

我有一個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

將表格行復制到具有多個條件的新表中 - 僅複製第一行？

回答

相關問題