根据条件将数据从一个工作表复制到另一个工作表

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

我想将选定的列粘贴到 DELIVERY 表中，如果我将“Unit”值传递为“D03-LAG R”，那么 DELIVERY 文件中的输出应该如下所示；

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 中执行轻松找出详细信息：
- 菜单视图/宏/注册宏（或类似的东西；我有意大利语版本）
- 手动做任何你想自动化的事情
- 菜单视图/宏/中断注册
- 菜单查看/宏/查看/修改

希望对你有帮助