VBA：整理非矩形相交区域（编辑版）

这个场景我太熟悉了——用Intersect拿到的分散区域，直接遍历的话会先扫完一个整块区域再跳下一个，完全打乱了原有的行列顺序。针对你要提取数据、消除空白间隔的需求，给你两个靠谱的实现思路：

思路1：按原始行列顺序逐个读取（最直观可控） #

既然知道目标行和列的范围字符串，我们可以先把这些行和列拆分成单独的行号、列号，然后通过双重循环先按行、再按列的顺序读取每个单元格，这样就能完美保证顺序和原工作表一致，还能顺便过滤空白单元格（如果需要的话）。

代码示例： #

Sub ExtractDataInOrder()
    Dim insurance As String, from As String
    Dim rngRows As String, rngCols As String
    ' 这里替换成你的实际参数
    insurance = "你的工作簿名.xlsx"
    from = "你的工作表名"
    rngRows = "16:24,27:32,35:39"
    rngCols = "E:E,I:I,M:M"
    
    Dim ws As Worksheet
    Set ws = Workbooks(insurance).Worksheets(from)
    
    ' 1. 拆分目标行号为数组
    Dim rowArr As Variant
    rowArr = GetAllRowNumbers(rngRows)
    
    ' 2. 拆分目标列号为数组
    Dim colArr As Variant
    colArr = GetAllColumnNumbers(rngCols, ws)
    
    ' 3. 准备存储结果的数组（或直接写入到新区域）
    Dim resultArr() As Variant
    ReDim resultArr(1 To UBound(rowArr), 1 To UBound(colArr)) ' 按原行列结构存储
    Dim i As Long, j As Long
    
    ' 4. 按行优先顺序读取数据
    For i = 1 To UBound(rowArr)
        For j = 1 To UBound(colArr)
            ' 如果要消除空白，可以加判断：If Not IsEmpty(ws.Cells(rowArr(i), colArr(j))) Then
            resultArr(i, j) = ws.Cells(rowArr(i), colArr(j)).Value
        Next j
    Next i
    
    ' 示例：把结果写入到当前工作表的A1开始区域
    ws.Range("A1").Resize(UBound(resultArr), UBound(resultArr, 2)).Value = resultArr
End Sub

' 辅助函数：拆分行范围字符串为所有行号的数组
Function GetAllRowNumbers(rngRowStr As String) As Variant
    Dim rowParts As Variant, part As Variant
    Dim startRow As Long, endRow As Long, r As Long
    Dim tempList As Collection
    
    Set tempList = New Collection
    rowParts = Split(rngRowStr, ",")
    
    For Each part In rowParts
        If InStr(part, ":") > 0 Then
            startRow = CLng(Split(part, ":")(0))
            endRow = CLng(Split(part, ":")(1))
            For r = startRow To endRow
                tempList.Add r
            Next r
        Else
            tempList.Add CLng(part)
        End If
    Next part
    
    ' 转成数组
    Dim resultArr() As Long
    ReDim resultArr(1 To tempList.Count)
    For r = 1 To tempList.Count
        resultArr(r) = tempList(r)
    Next r
    GetAllRowNumbers = resultArr
End Function

' 辅助函数：拆分列范围字符串为所有列号的数组
Function GetAllColumnNumbers(rngColStr As String, ws As Worksheet) As Variant
    Dim colParts As Variant, part As Variant
    Dim startCol As Long, endCol As Long, c As Long
    Dim tempList As Collection
    
    Set tempList = New Collection
    colParts = Split(rngColStr, ",")
    
    For Each part In colParts
        If InStr(part, ":") > 0 Then
            startCol = ws.Range(Split(part, ":")(0)).Column
            endCol = ws.Range(Split(part, ":")(1)).Column
            For c = startCol To endCol
                tempList.Add c
            Next c
        Else
            tempList.Add ws.Range(part).Column
        End If
    Next part
    
    ' 转成数组
    Dim resultArr() As Long
    ReDim resultArr(1 To tempList.Count)
    For c = 1 To tempList.Count
        resultArr(c) = tempList(c)
    Next c
    GetAllColumnNumbers = resultArr
End Function

思路2：遍历Intersect区域的每一行（适合已拿到Rng的情况） #

如果你已经通过Intersect得到了Rng，也可以直接遍历Rng的每一行，再在每行里提取目标列的数据，这样也能保证行顺序。

代码示例： #

Sub TraverseRngByRow()
    Dim insurance As String, from As String
    Dim rngRows As String, rngCols As String
    insurance = "你的工作簿名.xlsx"
    from = "你的工作表名"
    rngRows = "16:24,27:32,35:39"
    rngCols = "E:E,I:I,M:M"
    
    Dim ws As Worksheet
    Set ws = Workbooks(insurance).Worksheets(from)
    
    Dim rows As Range, cols As Range, Rng As Range
    Set rows = ws.Range(rngRows)
    Set cols = ws.Range(rngCols)
    Set Rng = Application.Intersect(rows, cols)
    
    Dim targetCols As Range
    Set targetCols = cols ' 目标列集合
    
    Dim resultArr() As Variant
    Dim rowCount As Long, colCount As Long
    rowCount = rows.Cells.Count ' 总目标行数
    colCount = cols.Cells.Count ' 总目标列数
    ReDim resultArr(1 To rowCount, 1 To colCount)
    
    Dim area As Range, row As Range
    Dim currentRowIdx As Long, colIdx As Long
    currentRowIdx = 1
    
    ' 遍历每个区域的每一行
    For Each area In Rng.Areas
        For Each row In area.Rows
            colIdx = 1
            ' 遍历目标列，提取当前行对应列的值
            For Each col In targetCols.Columns
                resultArr(currentRowIdx, colIdx) = row.Cells(1, col.Column - row.Column + 1).Value
                colIdx = colIdx + 1
            Next col
            currentRowIdx = currentRowIdx + 1
        Next row
    Next area
    
    ' 写入结果到工作表
    ws.Range("A1").Resize(rowCount, colCount).Value = resultArr
End Sub

关键说明： #

• 思路1的优势是完全不受Intersect返回的区域结构影响，直接按原始行列顺序读取，适合需要严格保持行顺序的场景；
• 思路2适合已经拿到Rng对象的情况，通过遍历每个Area里的行来保证顺序；
• 如果要“消除空白间隔”，只需要在读取值的时候加个判断，跳过空白单元格，然后动态调整结果数组的大小即可。

内容的提问来源于stack exchange，提问作者c-dube