vba copy discontinuous range cells

Question

I'm trying to copy discontinuous range cells to another sheet.

my first range is on sheet Dati, range A3:G300
sencond range is on sheet Dati, range AA3:AA300
Third range is on sheet Dati, range AC3:AC300
my destination is on sheet Calcolo, range A3:I300
I want to use union(range1, range2, range3) to create a new range and move/copy it on range A3:I300 of Calcolo sheet

My code is the following but there's a problem because on destination sheet "Calcolo" from A3 to G300 data are correct and from H3 to I300 my data are not considered with #N/D values.

Sub copia()

Dim SelectA As Range
Dim SelectB As Range
Dim SelectC As Range
Dim UnionABC As Range
Dim RangeInc As Range

Set SelectA = Sheets("Dati").Range("A3:G300")
Set SelectB = Sheets("Dati").Range("AA3:AA300")
Set SelectC = Sheets("Dati").Range("AC3:AC300")
Set UnionABC = Union(SelectA, SelectB, SelectC)
Set RangeInc = Sheets("Calcolo").Range("A3:I300")

RangeInc = UnionABC.Value

End Sub

Any help to find errors or any idea to recode it? Thank you

Unknown Unknown · Accepted Answer · 2018-10-14T11:55:48

Forget the clipboard and use direct value transfer with an intermediary variant array.

sub copia2()

    dim arr as variant, tmp as variant, i as long

    with workSheets("Dati")
        arr = .Range("A3:G300").value

        'collect AA
        tmp = .Range("AA3:AA300").value
        'make room for AA
        redim preserve arr(lbound(arr, 1) to ubound(arr, 1), _
                           lbound(arr, 2) to ubound(arr, 2) + 1)
        'transfer AA
        for i = lbound(arr, 1) to ubound(arr, 1)
            arr(i, ubound(arr, 2)) = tmp(i, 1)
        next i

        'collect AC
        tmp = .Range("AC3:AC300").value
        'make room for AC
        redim preserve arr(lbound(arr, 1) to ubound(arr, 1), _
                           lbound(arr, 2) to ubound(arr, 2) + 1)
        'transfer AC
        for i = lbound(arr, 1) to ubound(arr, 1)
            arr(i, ubound(arr, 2)) = tmp(i, 1)
        next i

    end with

    with workSheets("Calcolo")

       'transfer values to destination
        .Range("A3").resize(ubound(arr, 1), ubound(arr, 2)) = arr

    end with

end sub

vba copy discontinuous range cells

2 Answers