For loop, compare a pair of cells in a range on one sheet to a pair of cells in a range on another sheet, copy and paste based on match

[arg123]

Hello hello. I think I've hit a wall of creative thinking or maxed the extent of my knowledge or maybe it's just been a long weekend...

I would like to look at a pair of neighboring cells on one sheet and compare them to a pair of neighboring cells on another sheet. Then, if the pairs match, copy an offset set of three cells from the second sheet to the first only when the two pairs match.

Hard to even dive into the VBA code because I don't think the varied attempts I have even come close.

Anyway, ahead of time, Thank you VERY kindly. This is a big hot mess. The lower code works - ish. But I cant extend it across the range and only per cell (not apply to all in the range).

Your time any any assistance is greatly appreciated.

Thinking:

As a non coded example - simplified without the proper contexts to underscore the simple logic
Ranges I'm working with:
Sheet1.range (A2:B200) = a
Sheet2.range(A20:B2000) = b
Sheet1.range(a.offset(0, 3), a.offset(0, 5)) = c

For each pair of cells in a [could be (A2:B2) or (A200:B200) or anything in between]
if a = b [could be (A20:B20) or (A2000:B2000) or anything in between] then
c.copy
b.(for matching pair).offset(0, 2).pastespecial pastevalues
End If
Next

Next being a (A3:B3), (A4:B4), etc...


When I try the following, it loops til it crashes -- also, I don't think its right at all.

Dim sampcol As Range
Set sampcol = Sheets("First").Range("A2:A600")

For Each cell In sampcol

Dim sampcolex As Range
Set sampcolex = Sheets("Second").Range("A21:A3094")
    
        For Each cell2 In sampcolex
    
Dim sampcolpset As Range
Set sampcolset = Worksheets("First").Range(cell.Offset(0, 5), cell.Offset(0, 7))
Dim sampltrgt As Range
Set sampltrgt = Worksheets("First").Range(cell, cell.Offset(0, 1))
Dim sampltrgtexp As Range
Set sampltrgtexp = Worksheets("Second").Range(cell2, cell2.Offset(0, 1))

            If cell.Value = cell2.Value And cell.Offset(0, 1).Value = cell2.Offset(0, 1).Value And cell.Value <> "" Or cell2.Value <> "" Then
                sampcolset.Copy
                
                If cell2.Value = cell.Value And cell2.Offset(0, 1).Value = cell.Offset(0, 1).Value Then
                    cell2.Offset(0, 2).PasteSpecial xlPasteValues, Transpose:=False
                End If
            End If
        Next
Next

The following code worked fine when Sheets("Second").Range("A21") is the only matching criteria, but of course it only works for that one cell.
Making the Sheets("Second").Range("A21:A3094") and Sheets("Second").Range("A21:A3094").Offset(0, 1) causes an error.

Dim sampcol As Range
Set sampcol = Sheets("First").Range("A2:A600")

For Each cell In sampcol

Dim sampcolpset As Range
Set sampcolset = Worksheets("First").Range(cell.Offset(0, 5), cell.Offset(0, 7))
Dim sampcolex As Range
Set sampcolex = Sheets("Second").Range("A21:A3094")

'Need the vollowing line to be through the range stated above - do I change the range to ("A21:A3094") and drop the .value - then same for the next ("A21:A3094").Offset(0, 1), drop the .value?
          If cell.Value = Sheets("Second").Range("A21").value And cell.Offset(0, 1).Value = Sheets("Second").Range("A21").Offset(0, 1).Value And cell2.Value <> "" Then
                sampcolset.Copy

          For each cell2 in sampcolex
                    If cell2.Value = cell.Value And cell2.Offset(0, 1).Value = cell.Offset(0, 1).Value Then
                             cell2.Offset(0, 2).PasteSpecial xlPasteValues, Transpose:=False
                    End If
          Next
          End If
Next

 

[Snakehips]

@arg123 Can you confirm.
There may be more than 1 matching pair in second sheet?
If there is a match, E,F,G of the match row are copied from First sheet to C,D,E of Second sheet in it's match row?

 

[arg123]

@arg123 Can you confirm.
There may be more than 1 matching pair in second sheet?
If there is a match, E,F,G of the match row are copied from First sheet to C,D,E of Second sheet in it's match row?

To your first question, there should not be more than one matching pair between the two comparable sets.
To your second, correct.

 

[arg123]

@arg123 Can you confirm.
There may be more than 1 matching pair in second sheet?
If there is a match, E,F,G of the match row are copied from First sheet to C,D,E of Second sheet in it's match row?@

@Snakehips (Thought I'd throw a tag on it, might let you knw of my response a little quicker) Cheers!

 

[Snakehips]

I have been away from PC for a couple of hours.

Try the below, which hopefully is looping in the way you intended.
On larger data set it could be more efficient to search for matches rather than loop but with your scale of data hopefully it should not be am issue.
Give it a try. If you then need to vary the ranges by finding the last row of data in one or the other ranges then that can easily be added.

Sub Test()
Dim FstA, FstB, FstC As Range
Dim SecA, SecB As Range

Set FstA = Sheets("First").Range("A2:A200")
Set SecA = Sheets("Second").Range("A20:A2000")

Application.ScreenUpdating = False   'Inhibit screen updating to aid speed
For Each FCell In FstA   'Loop through First
    If Not FCell = "" Then  'Ignore blank First cells
       For Each SCell In SecA  'Loop through Second
          'If A's AND B's  match then copy three values
         If FCell = SCell And FCell.Offset(0, 1) = SCell.Offset(0, 1) Then
        
          SCell.Offset(0, 2).Resize(1, 3).Value = FCell.Offset(0, 5).Resize(1, 3).Value
          
          Exit For  ' As there will only be one match
         End If
      Next SCell  'Otherwise Next second cell
         
     End If
       
       
       Next FCell ' Next first cell
Application.ScreenUpdating = True  'Reestablish screen updating
End Sub

Hope that helps.

 

[arg123]

I have been away from PC for a couple of hours.

Try the below, which hopefully is looping in the way you intended.
On larger data set it could be more efficient to search for matches rather than loop but with your scale of data hopefully it should not be am issue.
Give it a try. If you then need to vary the ranges by finding the last row of data in one or the other ranges then that can easily be added.

Sub Test()
Dim FstA, FstB, FstC As Range
Dim SecA, SecB As Range

Set FstA = Sheets("First").Range("A2:A200")
Set SecA = Sheets("Second").Range("A20:A2000")

Application.ScreenUpdating = False   'Inhibit screen updating to aid speed
For Each FCell In FstA   'Loop through First
    If Not FCell = "" Then  'Ignore blank First cells
       For Each SCell In SecA  'Loop through Second
          'If A's AND B's  match then copy three values
         If FCell = SCell And FCell.Offset(0, 1) = SCell.Offset(0, 1) Then
       
          SCell.Offset(0, 2).Resize(1, 3).Value = FCell.Offset(0, 5).Resize(1, 3).Value
         
          Exit For  ' As there will only be one match
         End If
      Next SCell  'Otherwise Next second cell
        
     End If
      
      
       Next FCell ' Next first cell
Application.ScreenUpdating = True  'Reestablish screen updating
End Sub

Hope that helps.

Feels similar to what was in my mind and I just couldn’t close. The wonderful thing is, besides this working wonderfully, is learning where I went wrong. Thank you for your time @Snakehips!

 

[Snakehips]

Feels similar to what was in my mind and I just couldn’t close. The wonderful thing is, besides this working wonderfully, is learning where I went wrong. Thank you for your time @Snakehips!

@arg123
That's great. You are most welcome!
BTW it looks like there are a couple of variables that I declared that turned out to be redundant. Not really an issue but can be deleted if you wish to tidy it up.