Using VBA to create a single range from multiple ranges

问题

Hello this is my first post as I've always been able to find my answers in previous posts... until now. There must be a post, but I couldn't find one addressing the issue I'm having. My skill level is intermediate at best :-)

I have some values in a tabular format. I want to create a range from that which excludes some rows. I felt like I was getting close with a union, but alas, no go. The code example is below. The result was a new range containing only the value of Rng1. Any suggestions would be greatly appreciated. Please let me know if I should provide anything else. Thank You!

Sub TestUnion()

    Dim Rng1 As Range, Rng2 As Range, NewRng As Range, OutputRng As Range
    
    Set Rng1 = Range("A1:D1")
    Set Rng2 = Range("A3:D5")
    Set NewRng = Union(Rng1, Rng2)
    Set OutputRng = Range("F1:I4")
    
    OutputRng.Value2 = NewRng.Value2

End Sub

回答1:

This code should do the job. Please try it.

Sub TestUnion()

    ' list source ranges comma-separated
    Const Sources   As String = "A1:D1,C5,A3:D5"
    Const Target    As String = "F1"

    Dim Src()       As String               ' converted from Sources
    Dim Data        As Variant              ' value of Src(i)
    Dim i           As Long                 ' index of Src()
    Dim Ct          As Long                 ' target column
    Dim Rt          As Long                 ' target row
    
    Src = Split(Sources, ",")
    Rt = Range(Target).Row
    Ct = Range(Target).Column
    
    For i = 0 To UBound(Src)
        Data = Range(Src(i)).Value
        If InStr(Src(i), ":") Then
            Cells(Rt, Ct).Resize(UBound(Data), UBound(Data, 2)).Value = Data
            Rt = Rt + UBound(Data)
        Else
            Cells(Rt, Ct).Value = Data
            Rt = Rt + 1
        End If
    Next i
End Sub

Just set the two constants at the top of the procedure and the code will do the rest. This arrangement isn't strictly necessary but to set it up takes very little time which will be save tenfold if you ever need to make a change.

回答2:

Get Multi Range

Option Explicit

Sub TESTgetMultiRange()
    On Error GoTo clearError
    Const dFirst As String = "F1"
    ' Define ranges.
    Dim Rng1 As Range: Set Rng1 = Range("A1:D1")
    Dim Rng2 As Range: Set Rng2 = Range("A3:D5")
    ' Define Source range (the union of all ranges).
    Dim sRng As Range: Set sRng = Union(Rng1, Rng2)
    'Debug.Print sRng.Address
    ' Write values from Source range to an array.
    Dim Data As Variant: Data = getMultiRange(sRng)
    ' Define Destination range.
    Dim dRng As Range
    Set dRng = Range(dFirst).Resize(UBound(Data, 1), UBound(Data, 2))
    'Debug.Print dRng.Address
    ' Write values from the array to the Destination range.
    dRng.Value = Data
    MsgBox "Copied range '" & sRng.Address(0, 0) & "' to range '" _
        & dRng.Address(0, 0) & "'.", vbInformation, "Success"
ProcExit:
    Exit Sub
clearError:
    Resume ProcExit
End Sub

Function getMultiRange(rng As Range) As Variant
    On Error GoTo clearError
    Dim aCount As Long: aCount = rng.Areas.Count
    Dim Data As Variant: ReDim Data(1 To aCount)
    Dim DataRows As Variant: ReDim DataRows(1 To aCount)
    Dim DataCols As Variant: ReDim DataCols(1 To aCount)
    Dim aRng As Range
    Dim n As Long
    For Each aRng In rng.Areas
        n = n + 1
        Data(n) = getRange(aRng)
        DataRows(n) = UBound(Data(n), 1)
        DataCols(n) = UBound(Data(n), 2)
    Next
    Dim Result As Variant
    ReDim Result(1 To Application.Sum(DataRows), 1 To Application.Max(DataCols))
    Dim i As Long, j As Long, k As Long
    For n = 1 To aCount
        For i = 1 To DataRows(n)
            k = k + 1
            For j = 1 To DataCols(n)
                Result(k, j) = Data(n)(i, j)
            Next j
        Next i
    Next n
    getMultiRange = Result
ProcExit:
    Exit Function
clearError:
    Resume ProcExit
End Function

Function getRange(rng As Range) As Variant
    On Error GoTo clearError
    Dim Data As Variant
    If rng.Rows.Count > 1 Or rng.Columns.Count > 1 Then
        Data = rng.Value
    Else
        ReDim Data(1 To 1, 1 To 1)
        Data(1, 1) = rng.Value
    End If
    getRange = Data
ProcExit:
    Exit Function
clearError:
    Resume ProcExit
End Function

来源：https://stackoverflow.com/questions/65227228/using-vba-to-create-a-single-range-from-multiple-ranges