Excel VBA Course
Excel VBA Course - From Beginner to Expert

200+ Video Lessons
50+ Hours of Video
200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

View Course

copy specific columns based on two cells values

0

hi 

 I try writing  macro  to  copy  specific  columns  A,B,E,F,S  from  SH1  to SH2   based on match  cells values  G1,H1  in SH2   with  columns  G,H in SH1  .  but nothing happens 

Sub MM1()
Dim r As Long, lr As Long
Dim WS As Worksheet, SH As Worksheet
Set WS = Sheets("SH1"): Set SH = Sheets("SH2")
lr = Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To lr
    If WS.Range("g" & r).Value = SH.Range("g1").Value And WS.Range("h" & r).Value = SH.Range("h1").Value Then
    WS.Range("A" & r & ":B" & r & ":E" & r & ":F" & r & ":S" & r).Copy
        With Sheets("SH2")
            Range("A" & lr + 1).PasteSpecial xlPasteValues
        End With
    End If
Next r

End Sub

Answer
Discuss

Answers

0
Selected Answer

Tubrak

I see two problems with your code- you are copying a discontinuous range but you are trying to paste it into row lr of SH1 (and remember that is something like 740 from SH1!).

In the modified code below, I've set a new variable Lrw for the last row in SH2 and used the Union method to select the cells. On Sh2 I've added headers in row 1 (and code to clear the results before the next run). Main changes/ comments are in bold:

Sub MM1()
Dim r As Long, lr As Long, Lrw As Long
Dim WS As Worksheet, SH As Worksheet

Set WS = Sheets("SH1"): Set SH = Sheets("SH2")
'Get last rows per sheet
lr = WS.Cells(Rows.Count, "A").End(xlUp).Row
Lrw = SH.Cells(Rows.Count, "A").End(xlUp).Row

' Stop refresh (for speed)
Application.ScreenUpdating = False
' Clear last results
SH.Range("A2:E" & Lrw).ClearContents

For r = 2 To lr
    If WS.Range("g" & r).Value = SH.Range("g1").Value And WS.Range("h" & r).Value = SH.Range("h1").Value Then
        With WS
            Union(.Range("A" & r & ":B" & r), .Range("E" & r & ":F" & r), .Range("S" & r)).Copy '
        End With

        With Sheets("SH2")
        'Get new last row for this sheet
        Lrw = .Cells(.Rows.Count, "A").End(xlUp).Row
            .Range("A" & Lrw + 1).PasteSpecial xlPasteValues
        End With
    End If
Next r
' Remove copy dotted line and refresh screen
Application.CutCopyMode = False
Application.ScreenUpdating = True

MsgBox "Brought " & Lrw & " results to sheet SH2"
End Sub
I also put this code behind your "BRING" button on SH2:
Private Sub CommandButton1_Click()
Call MM1
End Sub
Hope this makes sense and fixes your problem.
Discuss

Discussion

many  thanks  for  correcting  my  mistakes  !
tubrak (rep: 20) Nov 28, '21 at 10:40 am
Add to Discussion


Answer the Question

You must create an account to use the forum. Create an Account or Login