CODEWITHSUNDEEP
excelvba
Justin Moh
Justin Moh

Reputation: 1670

How to copy a union of discontinuous ranges and paste them into another sheet?

I've got a form in excel looks like this:

  E F G H ... N O P Q
  * *   *     * *   *
  * *   *     * *   *
              * *   *
              * *   *
              * *   *
T:* *   *   T:* *   *

  * *   *     * *   *
  * *   *     * *   *
  * *   *
  * *   *

T:* *   *   T:* *   *

  * *   *
  * *   *



T:* *   *

It consists of many small areas with subtotals - rows indicated with "T".

Column E is "Price" and "F" is Qty, the rest of them is either formula calculated, or empty. So I've written a function to collect data from "E", which is initially what I had wanted.

But now I also wanted to get data from "F" and "H" as well, when "E" is validated.

My code was: 

Private Function CollectCellsData(dataRange As Range) As Range
Dim cell As Range, newRange As Range

For Each cell In dataRange

    If Not cell.HasFormula = True And Not IsEmpty(cell.Value) Then
        If newRange Is Nothing Then
            Set newRange = cell
        Else
            Set newRange = Union(newRange, cell)
        End If
    End If
Next
Set CollectCellsData = newRange

End Function

Private Function CopyDataAndPaste(sSheet As Worksheet, sColumn As String, dSheet As Worksheet, dColumn As String)
Dim lastRow As Long
Dim dataRange As Range, newRange As Range

lastRow = sSheet.Cells(Rows.Count, sColumn).End(xlUp).Row
Set dataRange = sSheet.Range(sColumn & "3:" & sColumn & lastRow)
Set newRange = CollectCellsData(dataRange)

lastRow = dSheet.Cells(Rows.Count, dColumn).End(xlUp).Row
If Not newRange Is Nothing Then
    newRange.Copy
    dSheet.Range(dColumn & lastRow + 1).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
End If

End Function

And I thought the most simple way to do it was simply alternate:

Set newRange = Union(newRange, cell)

into:

Set newRange = Union(newRange, cell, cell.Offset(0,1), cell.Offset(0,3))

But apparently I was wrong. The error message is

"Error 1004: Command cannot be used on multiple selection"

I think I've made a conceptional mistake. But if a

Union(range1, range2, range3)

would work with .Copy, why not in my case?

EDIT:

My bad, after I change the code into

Set newRange = Union(newRange, cell, cell.Offset(0,1), cell.Offset(0,3))

There's an error occurred at line

newRange.Copy

After the emphasis of Chrismas007 that the Union() method should work, and a hint of msgbox rng.address for debugging, I'm now able to make it work. The problem was with the assignment of "newRange", not the second one but the initial assignment. Like what Gary's Student has implied, Union collects cells in a uniform way.

'error
Set newRange = cell

'run
Set newRange = Union(cell, cell.Offset(0, 1), cell.Offset(0, 3))

Dropped programming for years and now I'm like the newbie 10 years ago!

Upvotes: 2

Views: 10756

Answers (2)

Gary's Student
Gary's Student

Reputation: 96753

It would be REALLY great to build a range of disjoint cells thru Union() and copy that range from one workbook to another, but Excel does not support that

Say we are interested in the filled cells in columns E,F,G

enter image description here

But not the empty cells. Here we create the dijoint range and then copy cell-by-cell:

Sub CopyDisjoint()
    Dim rBig As Range, rToCopy As Range, ady As String
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim r As Range
    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    Set rBig = sh1.Range("E:H")
    Set rToCopy = Intersect(rBig, sh1.Cells.SpecialCells(xlCellTypeConstants))

    For Each r In rToCopy
        ady = r.Address
        r.Copy sh2.Range(ady)
    Next r
End Sub

Upvotes: 1

Chrismas007
Chrismas007

Reputation: 6105

If you Copy a range with multiple selections, you cannot paste it into a range with multiple selections. Therefore, you have to set your paste range as ONE CELL (That being the cell in the top left of the range) to clear the error.

Test code:

Sub TestIt()

    Dim Rng As Range

    Set Rng = Union(Range("A1"), Range("B1"), Range("D1"))

    Rng.Copy

    'This code will error:
        Rng.Offset(1, 0).PasteSpecial xlPasteValues
    'This code will run:
        Range("A2").PasteSpecial xlPasteValues

    MsgBox Rng.Address

End Sub

Upvotes: 0

Related Questions