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?
 
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
 
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
Cloud Class® Course: Amazon Web Services - Basic

Are you thinking about creating an Amazon Web Services account for your business? Not sure where to start? In this course you’ll get an overview of the history of AWS and take a tour of their user interface.

 
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
 
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
 
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
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.