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中执行来轻松找到详细信息：
- 菜单视图/宏/注册宏（或类似的东西;我有意大利语版本）
- 手动执行任何您想要自动化的操作
- 菜单视图/宏/输入注册
- 菜单视图/宏/查看/修改

我希望这有助于你

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

1 个答案: