Excel VBA Course

(35% Sale Ends Jan. 26)

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 (35% Discount)

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: 10) 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