使用 VBA 从多个范围创建单个范围

Question

您好，这是我的第一篇文章，因为我一直能够在以前的文章中找到我的答案......直到现在。 必须有一个帖子，但我找不到解决我遇到的问题的帖子。 我的技能水平充其量是中级:-)

我有一些表格格式的值。 我想从排除某些行的范围中创建一个范围。 我觉得我正在接近一个工会，但唉，没有 go。 代码示例如下。 结果是一个仅包含 Rng1 值的新范围。 任何建议将不胜感激。 请让我知道我是否应该提供其他任何东西。 谢谢你！

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

Answer 1

这段代码应该可以完成这项工作。 请试一试。

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

只需在程序顶部设置两个常量，代码将执行 rest。 这种安排并不是绝对必要的，但设置它只需要很少的时间，如果您需要进行更改，这将节省十倍的时间。

Answer 2

获取多范围

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