VBA Copy Non-adjacent cells into 1 row, per worksheet..

B

BenGee

Board Regular
Joined
Mar 5, 2016
Messages
196
Hi

Here's my current code;
Code: 
    Dim ws As Worksheet
        
    For Each ws In ActiveWorkbook.Worksheets
    
        If ws.Name Like "*3CT" Then
            ws.Range("A29,C29,E29,G29,J29,N29,A34,C34,A36,C36,A38,C38").Copy
                Sheets("3CT Objectives").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
            ws.Range("A67,C67,E67,G67,J67,N67,A72,C72,A74,C74,A76,C76").Copy
                Sheets("3CT Objectives").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
            ws.Range("A105,C105,E105,G105,J105,N105,A110,C110,A112,C112,A114,C114").Copy
                Sheets("3CT Objectives").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
            ws.Range("A143,C143,E143,G143,J143,N143,A148,C148,A150,C150,A152,C152").Copy
                Sheets("3CT Objectives").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
            ws.Range("A181,C181,E181,G181,J181,N181,A186,C186,A188,C188,A190,C190").Copy
                Sheets("3CT Objectives").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
            ws.Range("A219,C219,E219,G219,J219,N219,A224,C224,A226,C226,A228,C228").Copy
                Sheets("3CT Objectives").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
        End If
        
    Next
    
Exit Sub

What I'm trying to do is go through each sheet name ending with "3CT" and copy the non-adjacent ranges defined above and paste into the next blank row within Worksheet "3CT Objective". But, It won't let me copy multiple selections.

I've tried looking around but anything I try doesn't seem to work!


This is my manual code which does work (but given I'd have to write / adapt 30+ times is something like 2400+ different lines so trying to shorten it). The "Name" also varies by sheet but the 3CT is always present in the sheet name;
Code: 
    ActiveSheet.Range("A5") = "Name"
    ActiveSheet.Range("B5") = Worksheets("Name 3CT").Range("A29")
    ActiveSheet.Range("C5") = Worksheets("Name 3CT").Range("C29")
    ActiveSheet.Range("D5") = Worksheets("Name 3CT").Range("E29")
    ActiveSheet.Range("E5") = Worksheets("Name 3CT").Range("G29")
    ActiveSheet.Range("F5") = Worksheets("Name 3CT").Range("J29")
    ActiveSheet.Range("G5") = Worksheets("Name 3CT").Range("N29")
    ActiveSheet.Range("H5") = Worksheets("Name 3CT").Range("A34")
    ActiveSheet.Range("I5") = Worksheets("Name 3CT").Range("C34")
    ActiveSheet.Range("J5") = Worksheets("Name 3CT").Range("A36")
    ActiveSheet.Range("K5") = Worksheets("Name 3CT").Range("C36")
    ActiveSheet.Range("L5") = Worksheets("Name 3CT").Range("A38")
    ActiveSheet.Range("M5") = Worksheets("Name 3CT").Range("C38")
    
    ActiveSheet.Range("A6") = "Name"
    ActiveSheet.Range("B6") = Worksheets("Name 3CT").Range("A67")
    ActiveSheet.Range("C6") = Worksheets("Name 3CT").Range("C67")
    ActiveSheet.Range("D6") = Worksheets("Name 3CT").Range("E67")
    ActiveSheet.Range("E6") = Worksheets("Name 3CT").Range("G67")
    ActiveSheet.Range("F6") = Worksheets("Name 3CT").Range("J67")
    ActiveSheet.Range("G6") = Worksheets("Name 3CT").Range("N67")
    ActiveSheet.Range("H6") = Worksheets("Name 3CT").Range("A72")
    ActiveSheet.Range("I6") = Worksheets("Name 3CT").Range("C72")
    ActiveSheet.Range("J6") = Worksheets("Name 3CT").Range("A74")
    ActiveSheet.Range("K6") = Worksheets("Name 3CT").Range("C74")
    ActiveSheet.Range("L6") = Worksheets("Name 3CT").Range("A76")
    ActiveSheet.Range("M6") = Worksheets("Name 3CT").Range("C76")
    
    ActiveSheet.Range("A7") = "Name"
    ActiveSheet.Range("B7") = Worksheets("Name 3CT").Range("A105")
    ActiveSheet.Range("C7") = Worksheets("Name 3CT").Range("C105")
    ActiveSheet.Range("D7") = Worksheets("Name 3CT").Range("E105")
    ActiveSheet.Range("E7") = Worksheets("Name 3CT").Range("G105")
    ActiveSheet.Range("F7") = Worksheets("Name 3CT").Range("J105")
    ActiveSheet.Range("G7") = Worksheets("Name 3CT").Range("N105")
    ActiveSheet.Range("H7") = Worksheets("Name 3CT").Range("A110")
    ActiveSheet.Range("I7") = Worksheets("Name 3CT").Range("C110")
    ActiveSheet.Range("J7") = Worksheets("Name 3CT").Range("A112")
    ActiveSheet.Range("K7") = Worksheets("Name 3CT").Range("C112")
    ActiveSheet.Range("L7") = Worksheets("Name 3CT").Range("A114")
    ActiveSheet.Range("M7") = Worksheets("Name 3CT").Range("C114")
    
    ActiveSheet.Range("A8") = "Name"
    ActiveSheet.Range("B8") = Worksheets("Name 3CT").Range("A143")
    ActiveSheet.Range("C8") = Worksheets("Name 3CT").Range("C143")
    ActiveSheet.Range("D8") = Worksheets("Name 3CT").Range("E143")
    ActiveSheet.Range("E8") = Worksheets("Name 3CT").Range("G143")
    ActiveSheet.Range("F8") = Worksheets("Name 3CT").Range("J143")
    ActiveSheet.Range("G8") = Worksheets("Name 3CT").Range("N143")
    ActiveSheet.Range("H8") = Worksheets("Name 3CT").Range("A148")
    ActiveSheet.Range("I8") = Worksheets("Name 3CT").Range("C148")
    ActiveSheet.Range("J8") = Worksheets("Name 3CT").Range("A150")
    ActiveSheet.Range("K8") = Worksheets("Name 3CT").Range("C150")
    ActiveSheet.Range("L8") = Worksheets("Name 3CT").Range("A152")
    ActiveSheet.Range("M8") = Worksheets("Name 3CT").Range("C152")
    
    ActiveSheet.Range("A9") = "Name"
    ActiveSheet.Range("B9") = Worksheets("Name 3CT").Range("A181")
    ActiveSheet.Range("C9") = Worksheets("Name 3CT").Range("C181")
    ActiveSheet.Range("D9") = Worksheets("Name 3CT").Range("E181")
    ActiveSheet.Range("E9") = Worksheets("Name 3CT").Range("G181")
    ActiveSheet.Range("F9") = Worksheets("Name 3CT").Range("J181")
    ActiveSheet.Range("G9") = Worksheets("Name 3CT").Range("N181")
    ActiveSheet.Range("H9") = Worksheets("Name 3CT").Range("A186")
    ActiveSheet.Range("I9") = Worksheets("Name 3CT").Range("C186")
    ActiveSheet.Range("J9") = Worksheets("Name 3CT").Range("A188")
    ActiveSheet.Range("K9") = Worksheets("Name 3CT").Range("C188")
    ActiveSheet.Range("L9") = Worksheets("Name 3CT").Range("A190")
    ActiveSheet.Range("M9") = Worksheets("Name 3CT").Range("C190")
    
    ActiveSheet.Range("A10") = "Name"
    ActiveSheet.Range("B10") = Worksheets("Name 3CT").Range("A219")
    ActiveSheet.Range("C10") = Worksheets("Name 3CT").Range("C219")
    ActiveSheet.Range("D10") = Worksheets("Name 3CT").Range("E219")
    ActiveSheet.Range("E10") = Worksheets("Name 3CT").Range("G219")
    ActiveSheet.Range("F10") = Worksheets("Name 3CT").Range("J219")
    ActiveSheet.Range("G10") = Worksheets("Name 3CT").Range("N219")
    ActiveSheet.Range("H10") = Worksheets("Name 3CT").Range("A224")
    ActiveSheet.Range("I10") = Worksheets("Name 3CT").Range("C224")
    ActiveSheet.Range("J10") = Worksheets("Name 3CT").Range("A226")
    ActiveSheet.Range("K10") = Worksheets("Name 3CT").Range("C226")
    ActiveSheet.Range("L10") = Worksheets("Name 3CT").Range("A228")
    ActiveSheet.Range("M10") = Worksheets("Name 3CT").Range("C228")

Any help would be appreciated!
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Sort by date Sort by votes
How about this: I did not do your entire code (lazy today), but if you follow and extend the method that I highlighted in red, it should work.

Code: 
Sub CopyNonCon()


    Dim ws As Worksheet
[COLOR=#ff0000]    Dim rng As Range[/COLOR]
    
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name Like "*3CT" Then
            With ws
[COLOR=#ff0000]                Set rng = Application.Union(.Range("A29"), .Range("C29"), .Range("E29"))    'etc.[/COLOR]
[COLOR=#ff0000]                rng.Copy[/COLOR]
[COLOR=#ff0000]                Sheets("3CT Objectives").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues[/COLOR]
[COLOR=#ff0000]                Set rng = Application.Union(.Range("A105"), .Range("C105"), .Range("E105")) 'etc[/COLOR]
[COLOR=#ff0000]                rng.Copy[/COLOR]
                ws.Range("A67,C67,E67,G67,J67,N67,A72,C72,A74,C74,A76,C76").Copy
                Sheets("3CT Objectives").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
                ws.Range("A105,C105,E105,G105,J105,N105,A110,C110,A112,C112,A114,C114").Copy
                Sheets("3CT Objectives").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
                ws.Range("A143,C143,E143,G143,J143,N143,A148,C148,A150,C150,A152,C152").Copy
                Sheets("3CT Objectives").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
                ws.Range("A181,C181,E181,G181,J181,N181,A186,C186,A188,C188,A190,C190").Copy
                Sheets("3CT Objectives").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
                ws.Range("A219,C219,E219,G219,J219,N219,A224,C224,A226,C226,A228,C228").Copy
                Sheets("3CT Objectives").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
            End With
        End If
    Next
    
End Sub

I hope this helps.
 
Upvote 0
Thank you for replying igold, appreciate the help!

So I've done the first few lines and tested. Code is;
Code: 
    Dim ws As Worksheet
    Dim rng As Range
    
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name Like "*3CT" Then
            With ws
                Set rng = Application.Union(.Range("A29"), .Range("C29"), .Range("E29"), .Range("G29"), .Range("J29"), .Range("N29"), .Range("A34"), .Range("C34"), .Range("A36"), .Range("C36"), .Range("A38"), .Range("C38"))
                [COLOR=#FF0000]rng.Copy[/COLOR]
                Sheets("3CT Objectives").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
                Set rng = Application.Union(.Range("A67"), .Range("C67"), .Range("E67"), .Range("G67"), .Range("J67"), .Range("N67"), .Range("A72"), .Range("C72"), .Range("A74"), .Range("C74"), .Range("A76"), .Range("C76"))
                rng.Copy
                Sheets("3CT Objectives").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
            End With
        End If
    Next

However an error comes up saying that my command cannot be used on multiple selections (in red above). Have I missed something?
 
Upvote 0
Untested:
Code: 
Sub CopyData()
    Application.ScreenUpdating = False
    Dim rng As Range
    Dim x As Long: x = 2
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name Like "*3CT" Then
            For Each rng In ws.Range("A29,C29,E29,G29,J29,N29,A34,C34,A36,C36,A38,C38")
                Sheets("3CT Objectives").Cells(Rows.Count, x).End(xlUp).Offset(1, 0) = rng
                x = x + 1
            Next rng
            x = 2
            For Each rng In ws.Range("A67,C67,E67,G67,J67,N67,A72,C72,A74,C74,A76,C76")
                Sheets("3CT Objectives").Cells(Rows.Count, x).End(xlUp).Offset(1) = rng
                x = x + 1
            Next rng
            x = 2
            For Each rng In ws.Range("A105,C105,E105,G105,J105,N105,A110,C110,A112,C112,A114,C114")
                Sheets("3CT Objectives").Cells(Rows.Count, x).End(xlUp).Offset(1) = rng
                x = x + 1
            Next rng
            x = 2
            For Each rng In ws.Range("A143,C143,E143,G143,J143,N143,A148,C148,A150,C150,A152,C152").Copy
                Sheets("3CT Objectives").Cells(Rows.Count, x).End(xlUp).Offset(1) = rng
                x = x + 1
            Next rng
            x = 2
            For Each rng In ws.Range("A181,C181,E181,G181,J181,N181,A186,C186,A188,C188,A190,C190").Copy
                Sheets("3CT Objectives").Cells(Rows.Count, x).End(xlUp).Offset(1) = rng
                x = x + 1
            Next rng
            x = 2
            For Each rng In ws.Range("A219,C219,E219,G219,J219,N219,A224,C224,A226,C226,A228,C228").Copy
                Sheets("3CT Objectives").Cells(Rows.Count, x).End(xlUp).Offset(1) = rng
                x = x + 1
            Next rng
            x = 2
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
I am finding a little bizarre behavior as well.

These three lines definitely work, I stepped through using F8:

Code: 
Set rng = Application.Union(.Range("A29"), .Range("C29"), .Range("E29"), .Range("G29"), .Range("J29"), .Range("N29"))
rng.Copy
Sheets("3CT Objectives").Cells(Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues

However once I added .Range("A34") it failed, my first thought was that Excel did not like the non-contiguous rows so when we added Row 34 it was the problem. However the following also works, so that can't be the issue because we are using both non-contiguous Columns and Rows.

Code: 
Set rng = Application.Union(.Range("A34"), .Range("C34"), .Range("A36"), .Range("C36"), .Range("A38"), .Range("C38"))
rng.Copy

If I were you I would either try a different method or break your lines down into segments (so to speak) that do work, which can easily be done by stepping through the code with every new cell you add to the range.
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Solved
VBA to check if worksheet exists
Replies
8
Views
345
bdt
B
B
  • Question Question
VBA exports worksheet from XLSM to XLXS matching all source properties doesn't keep print area
Replies
0
Views
128
brentcole
B
U
  • Solved
VBA question involving 2 different workbooks
Replies
2
Views
551
ummjay
U
A
  • Solved
Copy/Paste Adjacent Cell
Replies
6
Views
384
mumps
mumps
N
  • Solved
Copy headers across sheets no longer works.
Replies
7
Views
664
NoSparks
N

Forum statistics

Threads
1,224,827
Messages
6,181,195
Members
453,021
Latest member
pingpong7117

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top