Selecting and pasting non-contiguous cell using VBA

I need to select non-contiguous cells in a sheet and paste them to specific columns on the next blank row of another sheet. The code below can copy non-contiguous cells and paste to specific cells on the required sheet, but I cannot adapt to get it to copy to the next blank row.

Sub Copycell()

    Dim rng1 As Range
    Set rng1 = Range("B2,B4,B6")
   
    Dim rng2 As Range
    Set rng2 = Sheets("list").Range("A2,B2,D2")
   
    Dim i As Long
    For Each cel In rng2
        cel.Value = rng1.Cells(i + 1)
        i = i + 1
        Next
       
End Sub
Suzanne McMorrowAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Roy CoxGroup Finance ManagerCommented:
Can you attach a small example workbook
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Not sure what exactly you are trying to achieve but give this a try to see if this is what you are trying to achieve.

Sub Copycell()
    Dim rng1 As Range
    Set rng1 = Range("B2,B4,B6")
    
    Dim rng2 As Range, cel As Range
    Set rng2 = Sheets("list").Range("A2,B2,D2")
    
    Dim i As Long
    For Each cel In rng2
        If cel.Value <> "" Then
            Set cel = Sheets("list").Cells(Rows.Count, cel.Column).End(xlUp).Offset(1)
        End If
        i = i + 1
        cel.Value = rng1.Areas(i)
    Next
        
End Sub

Open in new window

0
Suzanne McMorrowAuthor Commented:
Thanks for getting back to me.  I tried the code and when I ran this on the first sheet it worked, but when I tried running it from the second sheet I got a run-time error 1004.  I have attached a mock example workbook which hopefully illustrates what I am trying to achieve.  I am trying to copy specific cells (B2, B4, B6) from each worksheet (12,13,14) and paste to the next blank row in columns A, B and D in the 'list' sheet.  I have listed specific cells to paste to (A2, B2, D2), which I'm sure is incorrect but could not get A:A, B:B references to work.  Any advice you could give would be greatly appreciated.
Jobs.xlsm
0
Big Business Goals? Which KPIs Will Help You

The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

Roy CoxGroup Finance ManagerCommented:
Suzanne

Please attach your example to the question to give others a chance.

Sub Copycell()
    Dim oWs As Worksheet, DestSht As Worksheet
    Dim lNextRw As Long

    Set DestSht = Sheets("list")
    For Each oWs In ThisWorkbook.Worksheets
        With DestSht
            lNextRw = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        End With
        With oWs
            If .Name <> "list" Then
                .Range("B2").Copy DestSht.Cells(lNextRw, 1)
                .Range("B4").Copy DestSht.Cells(lNextRw, 2)
                .Range("B6").Copy DestSht.Cells(lNextRw, 4)
            End If
        End With
    Next oWs

End Sub

Open in new window

Jobs.xlsm
0
Suzanne McMorrowAuthor Commented:
This is great, thanks Roy, but can you modify to just copy from the active sheet? Additional sheets will be added to the workbook and I need to be able to run the macro to copy and paste for that specific sheet only.  At the moment the macro pastes the contents for all the sheets again.
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
I have tweaked and placed the code on Module1 and it works from all the sheets.
I have also assigned a shortcut key Ctrl+Shift+C to run the code.

Sub Copycell()
    Dim dws As Worksheet
    Set dws = Sheets("list")
    
    Dim rng1 As Range
    Set rng1 = Range("B2,B4,B6")
    
    Dim rng2 As Range
    Set rng2 = dws.Range("A2,B2,D2")
    
    Dim i As Long, dlr As Long
    For Each cel In rng2
        If cel.Value <> "" Then
            dlr = dws.Cells(Rows.Count, cel.Column).End(xlUp).Row + 1
            Set cel = dws.Cells(dlr, cel.Column)
        End If
        i = i + 1
        cel.Value = rng1.Areas(i)
        Next
End Sub

Open in new window

Jobs.xlsm
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Roy CoxGroup Finance ManagerCommented:
Would it not be better to have the code to delete the sheets after copying?
0
Suzanne McMorrowAuthor Commented:
I didn't define the problem accurately at the start so based on the information I had given, both Experts solutions were effective and extremely useful.  My thanks to both Roy and Subodh for all their help.
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome Suzanne!
0
Roy CoxGroup Finance ManagerCommented:
Your clarification said copy from each worksheet, so as I suggested I would remove the used worksheets or clear the lists and re-populate. That would be quicker tha manually selecting sheets
0
Suzanne McMorrowAuthor Commented:
Thanks Roy, I'll take a look at this.
0
Roy CoxGroup Finance ManagerCommented:
Hi Suzanne

This is how I would handle it. Instead of selecting sheets and running the code to import, this code will first delete any existing data in the list, then copy all the data from the other sheets. This means you can add or remove sheets.

Option Explicit

Sub Copycell()
    Dim oWs As Worksheet, DestSht As Worksheet
    Dim rData As Range
    Dim lNextRw As Long

    Set DestSht = Sheets("list")

    With DestSht
        Set rData = .Cells(1, 1).CurrentRegion
        If rData.Rows.Count > 1 Then
            Set rData = rData.Offset(1, 0).Resize(rData.Rows.Count - 1, rData.Columns.Count)
            rData.ClearContents#
        End If
    End With

    For Each oWs In ThisWorkbook.Worksheets
        With oWs

            If .Name <> "list" Then
                lNextRw = DestSht.Cells(DestSht.Rows.Count, 1).End(xlUp).Row + 1
                .Range("B2").Copy DestSht.Cells(lNextRw, 1)
                .Range("B4").Copy DestSht.Cells(lNextRw, 2)
                .Range("B6").Copy DestSht.Cells(lNextRw, 4)
            End If
        End With
    Next oWs

End Sub

Open in new window

Jobs-2-.xlsm
0
Suzanne McMorrowAuthor Commented:
This is working perfectly, Roy.  Thank you for your help.
0
Roy CoxGroup Finance ManagerCommented:
Pleased to help
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VBA

From novice to tech pro — start learning today.