Скопируйте строки таблицы в новую таблицу с несколькими критериями - только копирует первую строку?

Question

У меня есть проект, который я надеюсь, что некоторые из вас могут помочь мне с тем, где я ошибаюсь. Вот совок:

У меня есть рабочий лист 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-й строке их листа.

Любые идеи, как я могу получить скопированные данные во вторую таблицу? Дайте мне знать, если требуется более подробное разъяснение.

Answer 1

Не зная вашей полной структуры таблицы, я бы предположил, что последние ActiveSheet.Paste неоднократно вставляют новые строки поверх старых.

Попробуйте выполнить шаг за шагом, используя F8 в редакторе VB и посмотрев, что выбрано и где оно вставлено.

Два предложения;

1. Для небольших наборов данных с помощью цикла for i и попробуйте изменить команду paste к insert, так что новые строки добавляются в верхней части таблицы результатов.

2. Для больших наборов данных избегайте использования цикла. Вместо этого используйте фильтр, чтобы выбрать все нужные вам строки, скопировать отфильтрованные результаты и вставить их.

Из опыта метод петли легче писать, но замедлять работу над большими наборами данных. Я бы предложил что-то вроде этого;

'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 

Answer 2

Благодаря 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 строк разбиваются по-разному на около десяти рабочих листов, это будет мероприятие на весь день! Если есть лучший способ сделать это с фильтрацией, я буду для него все.