Copying a discontinuous range from one sheet to another

Question

VBA rookie here (and first-time poster) with what is probably a pretty basic question. However, I haven't found an answer anywhere on the internet (or in the reference books I have) so I'm pretty stumped.

how can I take a bunch of spaced-out columns in one sheet and stuff them into another sheet, but without the gaps?

For example, I want to copy the cells marked as x's from a sheet like this:

x . . . x x . . x . . x
x . . . x x . . x . . x
x . . . x x . . x . . x
x . . . x x . . x . . x
x . . . x x . . x . . x
x . . . x x . . x . . x
x . . . x x . . x . . x
x . . . x x . . x . . x
x . . . x x . . x . . x

To a different sheet like this:

x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 
x x x x x . . . . . 

Design constraints:

• Source range is disjointed columns. Destination is continuous block
  • e.g. Source "A3:B440, G3:G440, I3:I440" -> destination "A3:D440"
• Only the values. Destination has conditional formatting that needs to be preserved
• Destination is part of the DataBodyRange of a ListObject
• The source range columns are arbitrary. They're found by a header indexing function.
• The row-count is arbitrary, but the same for both source and destination.
• There are about 400 rows and 10-15 columns I'm trying to copy. Loops are... annoying.

This snippets gets the job done, but it bounces things back and forth too much, and takes way too long. I feel like this is The Wrong Way To Do It.

For Each hdrfield In ExportFields

    RawDataCol = s_RawData.HeaderColumnPositions(hdrfield)

    s_RawData.Activate
    s_RawData.Range(s_RawData.Cells(3, RawDataCol), s_RawData.Cells(LastRow, RawDataCol)).Copy (s_Console.Range(s_Console.Cells(3, i), s_Console.Cells(LastRow, i)))
    s_Console.Activate
    s_Console.Range(s_Console.Cells(3, i), s_Console.Cells(LastRow, i)).Select
    s_Console.Paste

    i = i + 1

Next hdrfield

This approach also works. It's faster, and it's reliable. It's what I've been doing, but hard-coding the source positions isn't going to work anymore.

'transfer just the important columns from the raw data sheet to the report line sheet
s_Console.Range("A3:A" & upperlimit).Value = s_RawData.Range("A3:A" & upperlimit).Value 'timestamp
s_Console.Range("B3:B" & upperlimit).Value = s_RawData.Range("I3:I" & upperlimit).Value 'H2.ppm
s_Console.Range("C3:C" & upperlimit).Value = s_RawData.Range("J3:J" & upperlimit).Value 'H2_DG.ppm
s_Console.Range("D3:D" & upperlimit).Value = s_RawData.Range("K3:K" & upperlimit).Value 'OilTemp or GasTemp
s_Console.Range("E3:E" & upperlimit).Value = s_RawData.Range("L3:L" & upperlimit).Value 'H2_G.ppm
s_Console.Range("F3:F" & upperlimit).Value = s_RawData.Range("q3:q" & upperlimit).Value 'H2_mt
s_Console.Range("G3:G" & upperlimit).Value = s_RawData.Range("r3:r" & upperlimit).Value 'H2_oo
s_Console.Range("H3:H" & upperlimit).Value = s_RawData.Range("s3:s" & upperlimit).Value 'H2_lg
s_Console.Range("I3:I" & upperlimit).Value = s_RawData.Range("t3:t" & upperlimit).Value 'R1
s_Console.Range("J3:J" & upperlimit).Value = s_RawData.Range("u3:u" & upperlimit).Value 'R2
s_Console.Range("K3:K" & upperlimit).Value = s_RawData.Range("ab3:ab" & upperlimit).Value 't1
s_Console.Range("L3:L" & upperlimit).Value = s_RawData.Range("ac3:ac" & upperlimit).Value 't2
s_Console.Range("M3:M" & upperlimit).Value = s_RawData.Range("ah3:Ah" & upperlimit).Value 'Cycle Type

Why can't I just have a hybrid of the two? Why won't this code work?

 s_console.range("A3:M" & lastrow).value = s_rawdata.exportrange

(i've already got a custom "exportrange" property written, which can select + copy the range I want... but I can't set the values of another range with it because it's discontinuous)

Thanks for the help! This seems like a fundamental piece of learning VBA that I just can't find any information about.

-Matt

Answer 1

The key thing to be aware of is that you can copy the whole discontinuous range at once, like this:

Sheet1.Range("A3:B440, G3:G440, I3:I440").Copy
Sheet2.Range("A3").PasteSpecial xlValues

Note that in the above Sheet1 and Sheet2 are codenames, but you'll probably use something like ThisWorkbook.Worksheets("mySheet").

I couldn't really be sure what else you're trying to do, so I just wrote some code. This finds the columns to copy by using Find and FindNext, searching for columns with "copy" in row 2:

Sub CopyDiscontiguousColumns()
Dim wsFrom As Excel.Worksheet
Dim wsTo As Excel.Worksheet
Dim RangeToCopy As Excel.Range
Dim HeaderRange As Excel.Range
Dim HeaderText As String
Dim FirstFoundHeader As Excel.Range
Dim NextFoundHeader As Excel.Range
Dim LastRow As Long

Set wsFrom = ThisWorkbook.Worksheets(1)
Set wsTo = ThisWorkbook.Worksheets(2)
'headers are in row 2
Set HeaderRange = wsFrom.Rows(2)
'This is the text that identifies columns to be copies
HeaderText = "copy"
With wsFrom
    'look for the first instance of "copy" in the header row
    Set FirstFoundHeader = HeaderRange.Find(HeaderText)
    'if "copy" is found, we're off and running
    If Not FirstFoundHeader Is Nothing Then
        LastRow = .Cells(.Rows.Count, FirstFoundHeader.Column).End(xlUp).Row
        Set NextFoundHeader = FirstFoundHeader
        'start to build the range with columns to copy
        Set RangeToCopy = .Range(.Cells(3, NextFoundHeader.Column), .Cells(.Rows.Count, NextFoundHeader.Column))
        'and then just keep doing the same thing in a loop until we get back to the start
        Do
        Set NextFoundHeader = HeaderRange.FindNext(NextFoundHeader)
            If Not NextFoundHeader Is Nothing Then
                Set RangeToCopy = Union(RangeToCopy, .Range(.Cells(3, NextFoundHeader.Column), .Cells(.Rows.Count, NextFoundHeader.Column)))
            End If
        Loop While Not NextFoundHeader Is Nothing And NextFoundHeader.Address <> FirstFoundHeader.Address
    End If
End With
RangeToCopy.Copy
Sheet2.Range("A3").PasteSpecial xlValues
End Sub

Answer 2

You could take advantage of the Application.Union function:

Sub macro1()

Dim rngUnion As Range

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

With s_RawData
    Set rngUnion = Application.Union(.Range("A3:B" & upperlimit), .Range("G3:G" & upperlimit), .Range("I3:I" & upperlimit))
    rngUnion.Copy Destination:=s_Console.Range("A1")
End With

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With


End Sub

Also I think (I haven't tested it) this should work as well (without all the selecting and bouncing around...and should be considerably faster than your original loop):

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

For Each hdrfield In ExportFields

    RawDataCol = s_RawData.HeaderColumnPositions(hdrfield)

    s_RawData.Range(s_RawData.Cells(3, RawDataCol), s_RawData.Cells(LastRow, RawDataCol)).Copy Destination:=s_Console.Range(s_Console.Cells(3, i), s_Console.Cells(LastRow, i))

    i = i + 1

Next hdrfield

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With