☰

如果值匹配，如何复制并粘贴到另一个工作表 - Excel VBA

tag-icon • tag-icon microsoft-excel worksheet-function vba macros
如果值匹配，如何复制并粘贴到另一个工作表 - Excel VBA

如果 Sheet1 Column F="NUMBERS"，我需要将值从 Sheet1 Columns(A:B) 复制并粘贴到 Sheet2 Columns(A:B)

Input

A 1 NUMBERS
B 2 TEXT
C 3 NUMBERS
D 4 TEXT
E 5 NUMBERS AND TEXT

OUTPUT
A 1
C 3

目前我使用自动过滤和复制，粘贴方法有时会出现错误（因为宏太长）。

Sheets("sheet1").Select
ActiveWorkbook.save
Range("A1:J1").Select
Selection.AutoFilter
ActiveSheet.Range("$A:$J").AutoFilter Field:=6, Criteria1:="Numbers"
 Columns("A:B").Select
    Selection.Copy

 Sheets("Sheet2").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

所以我需要找到值并复制粘贴方法（基于循环）。

答案1

您可以使用此宏将整行复制到另一张具有Number值的工作表中Column F。

Option Explicit

Sub CopyRowWithSpecificText()

Dim Cell As Range

With Sheets(1)
      For Each Cell In .Range("F1:F" & .Cells(.Rows.Count, "F").End(xlUp).Row)
        If Cell.Value = "Numbers" Then

            .Rows(Cell.Row).Copy Destination:=Sheets(2).Rows(Cell.Row)
        End If
    Next Cell
End With
End Sub

編輯 1：

-如果您不喜欢宏产生空白行（如果Sheet 1要复制的行中有任何空白行），请使用此代码。

    Sub CopyRowsWithNUMBER()

    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet


    Set Source = ActiveWorkbook.Worksheets("Sheet1")
    Set Target = ActiveWorkbook.Worksheets("Sheet2")

    j = 1     
    For Each c In Source.Range("F1:F20")   
        If c = "Numbers" Then
           Source.Rows(c.Row).Copy Target.Rows(j)
           j = j + 1
        End If
    Next c
    End Sub

編輯2：

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rngCheck As Range
    Dim CheckCell As Range
    Dim lRow As Long

    Set rngCheck = Intersect(Me.Columns("F"), Target)

    If Not rngCheck Is Nothing Then

        For Each CheckCell In rngCheck.Cells
            If CheckCell.Value = "Numbers" Then
                With Sheets("sheet2")
                    lRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                    Me.Cells(CheckCell.Row, "A").Copy Destination:=.Cells(lRow, "A")
                    Me.Cells(CheckCell.Row, "B").Copy Destination:=.Cells(lRow, "B")

                End With
            End If
        Next CheckCell
    End If

End Sub

怎么运行的：

  • C奥皮＆磷将此代码Sheet 1作为标准模块保存。
  • 一旦您Numbers在 的任何单元格中输入Column F，此代码就会将数据从Column A & B特定的行复制到Sheet 2。
  • 目标列应该与源列不同。

注意：

  • 工作表名称、列（F）有特定文本，且特定文本Number可调整。
  • 将工作簿保存为启用宏 ( .Xlsm)。

相关内容