Скопируйте данные из одного листа в другое по условию

Question

Я пытаюсь скопировать данные из одного листа в другой пустой рабочий лист в книге. Он имеет три столбца, в которых я хочу выполнить поиск определенного значения «Единица» и просто скопировать все записи с похожими значениями «Единица» во второй лист с аналогичной структурой столбцов.

**Doc_number**  **Doc_version**   **Unit** 
43449      01      D013-LAG R 
43450      02      D013-LAG R 
43451      01      D013-DAMP 
43452      02      D013-DAMP 

Выход должен быть таким, если я предоставляю D013-LAG R в качестве входного значения;

**Doc_number**  **Doc_version**   **Unit** 
43449     01      D013-LAG R 
43450     02      D013-LAG R 

Я хочу, чтобы вставить выбранный столбец до доставки листа, как если бы передать значение «блок» как «D03-LAG R», то выходной сигнал в файле поставки должен быть так же, как следующим образом;

Doc_version  Unit 
01    D013-LAG R 
02    D013-LAG R 

Это больше, как я хочу, чтобы выбрать всю строку, а затем вставить данные в другую таблицу по столбцам, которые я хочу. Я не хочу, чтобы вся строка была вставлена ​​так, как есть.

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

Sub Row_Copy() 
Dim sheet1 As Worksheet, sheet2 As Worksheet 
Dim i As Integer, k As Integer 
Dim Sheet1LR As Long, Sheet2LR As Long 

Set sheet1 = Sheets("MASTER") 
Set sheet2 = Sheets("DELIVERY") 

Sheet1LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row + 1 
Sheet2LR = Sheet2.Range("A" & Rows.Count).End(xlUp).Row + 1 

i = 2 
k = Sheet2LR 

Do Until i = Sheet1LR 
If Trim(sheet1.Cells(i, 26).Value) = "D013-LAG R" Then 
    With sheet1 
     .Range(.Cells(i, 1), .Cells(i, 26)).Copy 
    End With 

    With sheet2 
     .Cells(k, 1).PasteSpecial 
     .Cells(k, 1).Offset(1, 0).PasteSpecial 
    End With 
    End If 
    k = k + 1 
    i = i + 1 

Loop 

MsgBox (Complete) 
ActiveWorkbook.Save 
Application.ScreenUpdating = False 

End Sub 

Это последний код, который я использую;

Sub CommandButton1_Click() 

Dim LSearchRow As Long 
Dim LCopyToRow As Long 
Dim CopyFromSht As Worksheet 
Dim CopyToSht As Worksheet 
Dim LCnt As Long 


On Error GoTo Err_Execute 
Set CopyFromSht = Workbooks("TestRow.xlsm").Sheets("MASTER") 
Set CopyToSht = Workbooks("TestRow.xlsm").Sheets("DELIVERY") 

With CopyFromSht 
    'Start search in row 4 
    LSearchRow = .Range("A" & Rows.Count).End(xlUp).Row 

    'Start copying data to row 2 in Sheet2 (row counter variable) 
    LCopyToRow = 2 

    For LCnt = 2 To LSearchRow 

    'If value in column Z = "Unit as needed", copy entire row to Sheet2 
     If .Range("Z" & LCnt).Value = "D013-LAG R" Then 

     'Select row in Sheet1 to copy 
      .Rows(LCnt).Copy Destination:=CopyToSht.Rows(LCopyToRow) 

     'Move counter to next row 
      LCopyToRow = LCopyToRow + 1 

     End If 
    Next LCnt 
End With 

Answer 1

Я написал макрос, который может дать вам представление о том, как решить вашу проблему:

Sub CopyRows() 

    ' Variables 
    Dim row_src As Integer 
    Dim row_dest As Integer 

    ' Inizialize row within destination sheet 
    row_dest = 1 

    ' Loop over all rows in source sheet 
    For row_src = 1 To 32767 

    ' Go to correct cell within source sheet 
    Sheets("Source").Select 
    Range("B" & CStr(row_src)).Select 

    ' Done if this row is empty 
    If (ActiveCell.Value = "") Then 
     Exit For 
    End If 

    ' Copy row if it's the header or if match found 
    If (row_src = 1) Or (ActiveCell.Value = "D013-LAG R") Then 

     ' Copy source row 
     Rows(CStr(row_src) & ":" & CStr(row_src)).Select 
     Selection.Copy 

     ' Go to destination row 
     Sheets("Destination").Select 
     Rows(CStr(row_dest) & ":" & CStr(row_dest)).Select 

     ' Copy row 
     ActiveSheet.Paste 

     ' Make sure next row is copied on the right place 
     row_dest = row_dest + 1 

    End If 

    Next 

End Sub 

В случае, если вы хотите скопировать только несколько столбцов из источника в листе назначения, попробуйте это :

' Copy columns B to E of source row 
Range("B" & CStr(row_src) & ":E" & CStr(row_src)).Select 
Selection.Copy 

' Go to destination 
Sheets("Destination").Select 
Range("B" & CStr(row_dest)).Select 

' Copy these columns 
ActiveSheet.Paste 

в случае колонки должны быть скопированы не раз подряд (например, B, D и F):

Range("B" & CStr(row_src) & ",D" & CStr(row_src) & ",F" & CStr(row_src)).Select 
Range("F" & CStr(row_src)).Activate 
Selection.Copy 

Кстати, я не знаю этого наизусть.
Вы можете легко узнать детали, выполнив в Excel:
- Вид меню/Макро/Регистрация Макро (или что-то подобное, я получил итальянскую версию)
- делать вручную, что вы хотите автоматизировать
- Вид меню/Макро/Interrput регистрация
- Вид меню/Макро/View/Изменить

Я надеюсь, что это поможет вам