Извлечение данных из Sheet1 в Sheet2 из списка данных

Question

Я довольно новичок в написании сценариев, и я застрял на том, что я считаю простым решением. Таким образом, в Excel у меня есть все мои данные на Листе 1 (импорт), и я хочу перенести данные из этого списка в мой Лист 2 (экспорт), используя Столбец А (на моем Листе 2) в качестве списка данных для извлечения.

Мне удалось получить данные для извлечения, однако я не могу получить их для получения кратных значений. Например, в моем столбце A (Sheet2) есть AB C, я нажимаю кнопку, чтобы извлечь данные, она вытягивает первый AB C на Sheet1, который находит, затем останавливается. Мне нужно, чтобы он стянул все листы AB C с листа1, прежде чем перейти к следующей ячейке для поиска.

Это мой первый пост, поэтому я прошу прощения, если это грубое чтение, или я должен был добавить больше контента.

--------------- Код ----------------

Private Sub DataImport_Click()

Dim I, Total, fRow As Integer
Dim Found As Range

'Listed Data to locate
Total = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row

'Where to locate data to export
For I = 2 To Total
    answer1 = Worksheets(2).Range("A" & I).Value
    Set Found = Sheets(1).Columns("F").Find(What:=answer1, LookAt:=xlWhole, SearchDirection:=x1Next)

'To Do when there is no data
If Found Is Nothing Then
'Leave the cell blank

'To Do when there is data & where/what data to pull
Else
    fRow = Sheets(1).Columns("F").Find(What:=answer1, LookAt:=xlWhole, SearchDirection:=x1Next).Row
    Worksheets(2).Range("C" & I).Value = Worksheets(1).Range("F" & fRow).Value
    Worksheets(2).Range("D" & I).Value = Worksheets(1).Range("G" & fRow).Value
    Worksheets(2).Range("E" & I).Value = Worksheets(1).Range("H" & fRow).Value
    Worksheets(2).Range("F" & I).Value = Worksheets(1).Range("C" & fRow).Value
    Worksheets(2).Range("G" & I).Value = Worksheets(1).Range("E" & fRow).Value


End If
Next I


End Sub

Answer 1

Я благодарен за помощь, и после того, как мы получили много возможных решений проблемы, мы в конечном итоге воспользовались приведенным ниже кодом. Еще раз спасибо всем за помощь!

Private Sub ExtractData_Click()

    Dim i As Integer
    Dim j As Integer
    Dim intSourceRowCt As Integer
    Dim intSearchRowCt As Integer
    Dim intCopyToRow As Integer
    'Set row to Start Copying to
    intCopyToRow = 2
    'Listed Data to locate
    intSourceRowCt = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
    intSearchRowCt = Sheets(1).Range("F" & Rows.Count).End(xlUp).Row
    'Loop through Source
    For i = 2 To intSourceRowCt
        'Loop through Search
        For j = 2 To intSearchRowCt
            'Copy Row if Matches
            If (Worksheets(1).Range("F" & j).Value = Worksheets(2).Range("A" & i).Value) Then
                Worksheets(2).Range("C" & intCopyToRow).Value = Worksheets(1).Range("F" & j).Value
                Worksheets(2).Range("D" & intCopyToRow).Value = Worksheets(1).Range("G" & j).Value
                Worksheets(2).Range("E" & intCopyToRow).Value = Worksheets(1).Range("H" & j).Value
                Worksheets(2).Range("F" & intCopyToRow).Value = Worksheets(1).Range("C" & j).Value
                Worksheets(2).Range("G" & intCopyToRow).Value = Worksheets(1).Range("E" & j).Value
                'Increment Insert Row
               intCopyToRow = intCopyToRow + 1
            End If
        Next j
    Next i
End Sub

Answer 2

Вы обрабатываете только первый найденный предмет. Вы можете использовать Do l oop для обработки всех из них, как показано ниже.

Set Found = Sheets(1).Columns("F").Find(What:=answer1, LookAt:=xlWhole, SearchDirection:=x1Next)
If Not Found Is Nothing Then
   Do Until Found Is Nothing
      'your logic for each found item
       Set Found = Sheets(1).Columns("F").FindNext(Found)
   Loop
End If