VBA to find the same value and copy range in different sheets

[darekknox]

Hi All,

I have trouble to figure out the right way to code the issue below:

Let's say on Sheet1 I have:

Value	Code
122	abc
344	efg

<tbody>
</tbody>

On Sheet2:

Value	Code
344	lmn
555	pqr

<tbody>
</tbody>

I want macro to check column "value" between two sheets if it finnds a match, I want it to copy the code.
Eg.
Macro finds that "344" is a match in both sheets so it copies code from sheet2.

Any idea how to code it best? Thanks for any help.

 

[WarPigl3t]

Sub myMacro()
     r = 2
     Do Until r > Sheet1.Range("A" & Rows.Count).End(xlUp).Row
          rr = 2
          Do Until rr > Sheet2.Range("A" & Rows.Count).End(xlUp).Row
               If Sheet1.Range("A" & r).Value = Sheet2.Range("A" & rr).Value Then
                    Sheet1.Range("B" & r).Value = Sheet2.Range("B" & rr).Value
                    Exit Do
               End If
               rr = rr + 1
          Loop
          r = r + 1
     Loop
End Sub

 

[darekknox]

Thank you very much for help. Are you able to advise how to code the "copying"" part??

Sub myMacro()
     r = 2
     Do Until r > Sheet1.Range("A" & Rows.Count).End(xlUp).Row
          rr = 2
          Do Until rr > Sheet2.Range("A" & Rows.Count).End(xlUp).Row
               If Sheet1.Range("A" & r).Value = Sheet2.Range("A" & rr).Value Then
                   [B]Sheet1.Range("A:E" & r).Copy[/B]
                    Exit Do
               End If
               rr = rr + 1
          Loop
          r = r + 1
     Loop
End Sub

I have trouble with part in bold, I would like it copy a wider range than 1 cell.

 

[WarPigl3t]

Well technically I didn't use a copy method. I just told it that the value of sheet1 column B should equal sheet2 column B. But since you want to copy instead, use the below code which is pretty similar. Also I think your copy range is incorrect in the code you provided so I changed it to make sense according to the specs you gave in the original post.

Sub myMacro()
     r = 2
     Do Until r > Sheet1.Range("A" & Rows.Count).End(xlUp).Row
          rr = 2
          Do Until rr > Sheet2.Range("A" & Rows.Count).End(xlUp).Row
               If Sheet1.Range("A" & r).Value = Sheet2.Range("A" & rr).Value Then
                    Sheet2.Range("B" & rr & ":E" & rr).Copy
                    Sheet1.Range("B" & r).PasteSpecial xlPasteValues
                    Application.CutCopyMode = False
                    Exit Do
               End If
               rr = rr + 1
          Loop
          r = r + 1
     Loop
End Sub

 

[darekknox]

Thank you. I have played around with it my code:

Sub myMacro()
Dim i As Integer
Sheets("ZZZZZ").Activate
For i = 7 To Range("A7").End(xlDown).Row

'Filtrowanie 

Sheets("XXXX").Activate
ActiveSheet.Range("$A$1:$J$147").AutoFilter Field:=10, Criteria1:="<>"
ActiveSheet.Range("$A$1:$J$147").AutoFilter Field:=2, Criteria1:=Worksheets("XXXXX").Cells(i, 7).Value

'Filtrwoanie 

Sheets("ZZZZZ").Activate
ActiveSheet.Range("$A$1:$J$147").AutoFilter Field:=2, Criteria1:=Worksheets("XXXXX").Cells(i, 2).Value

'Porownanie
'r/rr poczatkowy wiersz
     r = 2
     Do Until r > Sheets("XXXXX").Range("G" & Rows.Count).End(xlUp).SpecialCells(xlCellTypeVisible).Row
          rr = 3
          Do Until rr > Sheets("ZZZZZ").Range("H" & Rows.Count).End(xlUp).SpecialCells(xlCellTypeVisible).Row
               If Sheets("
xxxxxx").Range("G" & r).Value = Sheets("ZZZZZ").Range("H" & rr).Value Then
                    Sheets("ZZZZZ").Range("F" & rr & ":H" & rr).Copy
                    'Sheet2.Range("B" & rr & ":E" & rr).Copy
                    'Sheet1.Range("B" & r).PasteSpecial xlPasteValues
                    Application.CutCopyMode = False
                    Exit Do
               End If
               rr = rr + 1
          Loop
          r = r + 1
     Loop
     Next
End Sub

Do you have any idea how to get this code to compare values in filtered lists?? I tried with visble cells, but it's not working

 

[WarPigl3t]

I can tell you are pretty good at coding given your modifications of my code. I've never done filtered list comparisons but I have an idea that might work. You'll have to add two lines of code to the code you have for my idea to work. Under the first Do Until, and right above the rr = 3, add this line...
If Sheets("Sheet1Name").Rows(r).Visible = True Then
Now where do you think you put the End If statement? Right above the r = r + 1 of course.
Now for the second line of code which is pretty much the same thing. Under the second Do Until, and right above the big If statement that I don't want to type out, add this line...
If Sheets("Sheet2Name").Rows(rr).Visible = True Then
Now where do you think you put the End If statement? Right above the rr = rr + 1 of course. And if this doesn't work, I'm out of ideas.

 

[darekknox]

thanks, so close but still not working ;/ runtime error

 

[WarPigl3t]

Try
.Hidden = false
instead of
.Visible = True

 

[darekknox]

Thanks for help. I finally got it work. Maybe someone will find this useful, here is my entire code:

Sub myMacro()
Dim i As Integer
Sheets("AAAAA").Activate
For i = 7 To Range("A7").End(xlDown).Row

'Filtrowanie 

Sheets("BBB").Activate
ActiveSheet.Range("$A$1:$J$147").AutoFilter Field:=10, Criteria1:="<>"
ActiveSheet.Range("$A$1:$J$147").AutoFilter Field:=2, Criteria1:=Worksheets("AAAAA").Cells(i, 7).Value

'Filtrwoanie

Sheets("CCC").Activate
ActiveSheet.Range("$A$1:$J$147").AutoFilter Field:=2, Criteria1:=Worksheets("AAAAA").Cells(i, 2).Value

'Porownanie SRI/GRC
'r/rr poczatkowy wiersz

     r = 2

     Do Until r > Sheets("BBB").Range("G" & Rows.Count).End(xlUp).Row
     If Sheets("BBB").Rows(r).Hidden = False Then

          rr = 3
          
          Do Until rr > Sheets("CCC").Range("H" & Rows.Count).End(xlUp).Row
             
        
               If Sheets("CCC").Rows(rr).Hidden = False And Sheets("BBB").Range("G" & r).Value = Sheets("CCC").Range("H" & rr).Value Then
                    Sheets("CCC").Range("F" & rr & ":H" & rr).Copy
                    Sheets("AAAAA").Activate
                    Cells(i, 3).PasteSpecial xlPasteValues
                    If Sheets("BBB").Rows(r).Hidden = False Then
                    Sheets("BBB").Range("e" & r & ":g" & r).Copy
                    Sheets("AAAAA").Activate
                    Cells(i, 8).PasteSpecial xlPasteValues
                    'Sheet2.Range("B" & rr & ":E" & rr).Copy
                    'Sheet1.Range("B" & r).PasteSpecial xlPasteValues
                    Application.CutCopyMode = False
                    Exit Do
                    End If
               End If
            
               rr = rr + 1
          Loop
       End If
          r = r + 1
     Loop
     Next
End Sub