Find Match on Sheet2 from Sheet1 - Cut Match from Sheet1 to Sheet2

Question

New to VB and a bit lost...

I have one workbook with two sheets. I need to Compare col A on each sheet. If the computer name in Sheet1 Col A finds a match on Sheet2 A:A then the macro will add a line in sheet2 and add then data from Sheet1 cols A,B then del the data from Sheet1.

Sheet1
       A      |    B
|EVW7LT206152 | Hug,Aman
|WNW7LN000000 | Impo,MrsUn
|EVW7LT205803 | Doe,Jane
|EVW7LN205817 | Doe,John

Sheet2
      A          B             C          D
|EVW7LN205817| Doe,John | 12/20/2014 | 191.000.43.170
|EVW7LT206152| Hug,Aman | 12/20/2014 | 191.000.43.10
|NYW7LN000000| Impo,MrUn| 12/20/2014 | 191.000.43.197
|EVW7LT205803| Doe,Jane | 12/20/2014 | 191.000.43.145

Sheet1 (Finished)
     A         |      B
WNW7LN000000 | Impo,MrsUn

Sheet2 (Finished)
      A          B             C          D
|EVW7LN205817 | Doe,John | 12/20/2014 | 191.000.43.170
|EVW7LN205817 | Doe,John | |

|NYW7LN000000| Impo,MrUn | 12/20/2014 | 191.000.43.197

This was close but does not del matches from sheet 1 like in my example.

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

What exactly is your question? And what have you tried so far? — TheEngineer
i am looking for Macro that I can run that will create this outcome. I have created a script that will copy the info but it will not del the original and it will stop if there is no match. — CTRy

TheEngineer TheEngineer · Accepted Answer · 2014-12-29T22:25:44

First off, you should always avoid using Select and Selection as described here. Also, you will need to reference the sheet when using Cells, Rows, etc. when switching between sheets.

Your basic code will work, you just need to add a line to delete the row from 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

Your sub would basically stay the same. Just delete the line that uses Select and add a sheet reference, and turn off screen updating to speed it up:

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

Find Match on Sheet2 from Sheet1 - Cut Match from Sheet1 to Sheet2

1 Answers