macro that will match two different column from two different sheets

[p9j123]

Hello Excel Masters,

I badly need help here, I am working on a file that has two sheets.

I need a macro that will match EMPID and PROCODE in Sheet 1(April (2)) with Sheet 2 (Compre List), if found the entire row in Sheet 2 should be deleted then the EMPID[C] and PROCODE[D] should be posted in the next blank row of Sheet 1 ( and [D] of Sheet 1).
Few things to note.

1. Above square brackets represent column letters.
2. I need the macro to look for the first blank row between row 13 to row 25 only, not from the bottom of the sheet.
3. The macro will be run from different sheet (April (1), April (2), April (3), etc.)

Please see the link of the workbook for your reference.

https://app.box.com/s/tw1pzo3hhn1dbwmionpf

 

[NicholasP]

Not sure if understood your '13-25 blank row' criteria...currently this is set up to turn qualifying rows red. If you want to delete, take out the comments (')...

Try this:

Sub tests()


sht = ActiveSheet.Name

Dim x, y As Long

x = 1

Do
x = x + 1
Loop Until Cells(x, 4) <> ""

x = x + 1

y = x

Do
y = y + 1
Loop Until Cells(y, 4) = ""

y = y - 1

Dim rng As Range
Set rng = Range(Cells(x, 4), Cells(y, 4))


Sheets("Compre List").Activate

Z = Cells(Rows.Count, 3).End(xlUp).Row

Dim CompreRng As Range
Set CompreRng = Range(Cells(2, 4), Cells(Z, 4))


Sheets(sht).Activate

For Each cell In rng

Set c = CompreRng.Find(cell, , , xlWhole)
    If Not c Is Nothing Then
        If c.Offset(0, -1) = cell.Offset(0, -2) Then
            c.EntireRow.Interior.ColorIndex = 3
            ''c.EntireRow.Delete shift:=xlUp
        End If
    End If

Next
     






End Sub

 

[p9j123]

Thanks NicholasP. It did the tricks of matching the column.

For the next steps, can you assist me copying the Emp ID and ProCode from CompreSheet to April (2) sheet before deleting the rows on CompreSheet. The end result based on that example is that we have 2 sets of

AT156

VT4566

<tbody>
</tbody>

and

AT675

OR9135

<tbody>
</tbody>

on the April (2) Sheets.

 

[p9j123]

Not sure if understood your '13-25 blank row' criteria...currently this is set up to turn qualifying rows red. If you want to delete, take out the comments (')...

Try this:

Sub tests()


sht = ActiveSheet.Name

Dim x, y As Long

x = 1

Do
x = x + 1
Loop Until Cells(x, 4) <> ""

x = x + 1

y = x

Do
y = y + 1
Loop Until Cells(y, 4) = ""

y = y - 1

Dim rng As Range
Set rng = Range(Cells(x, 4), Cells(y, 4))


Sheets("Compre List").Activate

Z = Cells(Rows.Count, 3).End(xlUp).Row

Dim CompreRng As Range
Set CompreRng = Range(Cells(2, 4), Cells(Z, 4))


Sheets(sht).Activate

For Each cell In rng

Set c = CompreRng.Find(cell, , , xlWhole)
    If Not c Is Nothing Then
        If c.Offset(0, -1) = cell.Offset(0, -2) Then
            c.EntireRow.Interior.ColorIndex = 3
            ''c.EntireRow.Delete shift:=xlUp
        End If
    End If

Next
     






End Sub

I tried filling up row 3 of April (2) sheet and the macro stops doing the trick, please assist me Nicholas.

 

[NicholasP]

Try this...

Sub tests()


sht = ActiveSheet.Name

Dim x, y, lstrw As Long

x = 1

Do
x = x + 1
Loop Until Cells(x, 4) <> ""

x = x + 1

y = x

Do
y = y + 1
Loop Until Cells(y, 4) = ""

lstrw = y
y = y - 1

Dim rng As Range
Set rng = Range(Cells(x, 4), Cells(y, 4))


Sheets("Compre List").Activate

Z = Cells(Rows.Count, 3).End(xlUp).Row

Dim CompreRng As Range
Set CompreRng = Range(Cells(2, 4), Cells(Z, 4))


Sheets(sht).Activate

For Each cell In rng

Set c = CompreRng.Find(cell, , , xlWhole)
    If Not c Is Nothing Then
        If c.Offset(0, -1) = cell.Offset(0, -2) Then
            c.Copy Cells(lstrw, 4)
            c.Offset(0, -1).Copy Cells(lstrw, 2)
            c.EntireRow.Interior.ColorIndex = 3
            lstrw = lstrw + 1

            ''c.EntireRow.Delete shift:=xlUp
        End If
    End If

Next
     






End Sub

 

[NicholasP]

I tried filling up row 3 of April (2) sheet and the macro stops doing the trick, please assist me Nicholas.

This code starts at cell (D1) and checks each cell to see if it's blank. Once it finds one that's not blank, it defines the top of the range as that cell.

This code also then cycles through the cells from the top of the range (first cell in column D that has a value) until it finds a blank. In that way, it defines the bottom of the range

 

[NicholasP]

You could also inserting this portion of the code (clearly you don't need the commented out section, I've included it only to show you what to replace)

''x = 1
''
''Do
''x = x + 1
''Loop Until Cells(x, 4) <> ""
''
''x = x + 1

'''Alternatively, you could try this

Dim toprng
Set toprng = Range("D1:D" & Cells(Rows.Count, 4).End(xlUp).Row)

Set c = toprng.Find("ProCode", , , xlWhole)
x = c.Row

 

[p9j123]

Still the same NicholasP, can you assist me starting the macro from D12 instead?

 

[NicholasP]

Still the same NicholasP, can you assist me starting the macro from D12 instead?

Try this first:

Sub tests()


sht = ActiveSheet.Name

Dim x, y, lstrw As Long

Dim toprng
Set toprng = Range("D1:D" & Cells(Rows.Count, 4).End(xlUp).Row)

Set c = toprng.Find("ProCode", , , xlWhole)
x = c.Row

y = x

Do
y = y + 1
Loop Until Cells(y, 4) = ""

lstrw = y
y = y - 1

Dim rng As Range
Set rng = Range(Cells(x, 4), Cells(y, 4))


Sheets("Compre List").Activate

Z = Cells(Rows.Count, 3).End(xlUp).Row

Dim CompreRng As Range
Set CompreRng = Range(Cells(2, 4), Cells(Z, 4))


Sheets(sht).Activate

For Each cell In rng

Set c = CompreRng.Find(cell, , , xlWhole)
    If Not c Is Nothing Then
        If c.Offset(0, -1) = cell.Offset(0, -2) Then
            c.Copy Cells(lstrw, 4)
            c.Offset(0, -1).Copy Cells(lstrw, 2)
            c.EntireRow.Interior.ColorIndex = 3
            lstrw = lstrw + 1

            ''c.EntireRow.Delete shift:=xlUp
        End If
    End If

Next
     






End Sub

However, if you really want to start @ D12 all the time, just replace x = c.row with x = 12

 

[p9j123]

However, if you really want to start @ D12 all the time, just replace x = c.row with x = 12

Sorry NicholasP, it still the same even if I replaced x = c.row with x = 12.

Please bear with me.