从 Sheet1 在 Sheet2 上查找匹配 - 从 Sheet1 剪切匹配到 Sheet2答案

【问题标题】：Find Match on Sheet2 from Sheet1 - Cut Match from Sheet1 to Sheet2从 Sheet1 在 Sheet2 上查找匹配 - 从 Sheet1 剪切匹配到 Sheet2
【发布时间】：2014-12-30 06:25:44
【问题描述】：

VB 新手，有点迷茫...

我有一个带有两张工作表的工作簿。我需要比较每张纸上的 col A。如果 Sheet1 Col A 中的计算机名称在 Sheet2 A:A 上找到匹配项，则宏将在 sheet2 中添加一行，然后添加 Sheet1 cols A,B 中的数据，然后删除 Sheet1 中的数据。

表 1
       A      |    B
|EVW7LT206152 |拥抱，阿曼
|WNW7LN000000 | Impo,MrsUn
|EVW7LT205803 |能源部，简
|EVW7LN205817 |能源部，约翰

表 2
      A          B             C          D
|EVW7LN205817|能源部，约翰 | 2014 年 12 月 20 日 | 191.000.43.170
|EVW7LT206152|拥抱，阿曼 | 2014 年 12 月 20 日 | 191.000.43.10
|NYW7LN000000| Impo,先生| 2014 年 12 月 20 日 | 191.000.43.197
|EVW7LT205803|能源部，简 | 2014 年 12 月 20 日 | 191.000.43.145

Sheet1（完成）
     A         |      B
WNW7LN000000 |天啊，夫人

Sheet2（完成）
      A          B             C          D
|EVW7LN205817 |能源部，约翰 | 2014 年 12 月 20 日 | 191.000.43.170
|EVW7LN205817 |能源部，约翰 | |

|NYW7LN000000| Impo，先生 | 2014 年 12 月 20 日 | 191.000.43.197

这很接近，但不像我的示例中那样从表 1 中删除匹配项。

Function DoOne(RowIndex As Integer) As Boolean
    Dim Key
    Dim Target
    Dim Success
    Success = False
    If Not IsEmpty(Cells(RowIndex, 1).Value) Then
        Key = Cells(RowIndex, 1).Value

        Sheets("Sheet1").Select

        Set Target = Columns(1).Find(Key, LookIn:=xlValues)

        If Not Target Is Nothing Then
            Rows(Target.Row).Select
            Selection.Copy
            Sheets("Sheet2").Select
            Rows(RowIndex + 1).Select
            Selection.Insert Shift:=xlDown
            Rows(RowIndex + 2).Select
            Application.CutCopyMode = True
            Selection.Insert Shift:=xlDown, copyOrigin:=xlFormatFromLeftOrAbove
            Cells(RowIndex + 3, 1).Select
            Success = True
        End If

    End If
    DoOne = Success
End Function

Sub TheMacro()
    Dim RowIndex As Integer
    Sheets("Sheet2").Select
    RowIndex = Cells.Row
    While DoOne(RowIndex)
        RowIndex = RowIndex + 3
    Wend
End Sub

【问题讨论】：

您的问题到底是什么？到目前为止，您尝试过什么？
我正在寻找我可以运行的宏来创建这个结果。我创建了一个脚本，它将复制信息，但它不会删除原始信息，如果没有匹配，它将停止。
下面的答案对你有用吗？

标签： excel vba

【解决方案1】：

首先，您应该始终避免使用Select 和Selection，如here 所述。此外，在工作表之间切换时使用Cells、Rows 等时需要参考工作表。

您的基本代码将起作用，您只需添加一行即可从 Sheet1 中删除该行：

Function DoOne(RowIndex As Integer) As Boolean
    Dim Key
    Dim Target
    Dim Success
    Success = False
    If Not IsEmpty(Sheets("Sheet2").Cells(RowIndex, 1).Value) Then
        Key = Sheets("Sheet2").Cells(RowIndex, 1).Value

        Set Target = Sheets("Sheet1").Columns(1).Find(Key, LookIn:=xlValues)

        If Not Target Is Nothing Then
            Sheets("Sheet1").Rows(Target.Row).Copy
            Sheets("Sheet2").Rows(RowIndex + 1).Insert Shift:=xlDown
            Sheets("Sheet2").Rows(RowIndex + 2).Insert Shift:=xlDown, copyOrigin:=xlFormatFromLeftOrAbove
            Sheets("Sheet1").Rows(Target.Row).Delete
            Success = True
        End If

    End If
    DoOne = Success
End Function

您的潜艇基本上保持不变。只需删除使用Select 的行并添加工作表引用，然后关闭屏幕更新以加快速度：

Sub TheMacro()
    Application.ScreenUpdating = False
    Dim RowIndex As Integer

    RowIndex = Sheets("Sheet2").Cells.Row
    While DoOne(RowIndex)
        RowIndex = RowIndex + 3
    Wend
    Application.ScreenUpdating = True
End Sub

【讨论】：