Question

我正在寻找一些VBA，它将允许我在工作表上循环浏览几个不同的区域。不一定是单个单元，而是要从“当前区域”跳到下一个“当前区域”。一旦找到该区域，就应该选择并复制该区域。

我尝试设置StartCell（通过Cells.Find（What：=“ *”），然后使用该单元格选择相应的“当前区域”。问题是如何移动到下一个“当前区域”，直到工作表上的所有“当前区域”均已复制/粘贴。

到目前为止，我的结果是不一致的，有时会复制/粘贴所有必要的区域，但有时会忽略某些区域（相同的工作表，相同的数据）。

Set StartCell = Cells.Find(What:="*", _
                    After:=Cells(Rows.Count, Columns.Count), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)Do

            'Select Range and copy it
              If StartCell <> "" Then
              StartCell.currentregion.CopyPicture

            'Select a cell to paste the picture in
              Range("A16").PasteSpecial

            'Move to next range to be copied

            Set StartCell = StartCell.End(xlToRight).End(xlToRight)
           StartCell.Select
            End If

        Loop Until StartCell = ""

Answer 1

类似的东西应该起作用

Option Explicit

Public Sub ProcessEachRegion()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1") 'define your sheet

    Dim StartCell As Range
    Set StartCell = ws.Range("A1") 'define start cell

    Do Until StartCell.Column = ws.Columns.Count 'loop until end of columns
        With StartCell.CurrentRegion
            'do all your copy stuff here!
            '.Copy
            'Destination.Paste


            Set StartCell = .Resize(1, 1).Offset(ColumnOffset:=.Columns.Count - 1).End(xlToRight)
        End With
    Loop
End Sub

它会寻找上一个区域的下一个区域（在下面的示例中为1到5）。

Answer 2

主要子项（我将其命名为tgr）将调用名为GetAllPopulatedCells的函数，该函数定义工作表中所有填充单元格的范围。 .Areas属性将使您遍历每个区域。然后它将每个区域/区域复制为图片（仍然不确定为什么要这么做）并将其放在目标单元格中，然后根据需要调整目标单元格，以便所有粘贴的图像相互堆叠

Sub tgr()

    Dim ws As Worksheet
    Dim rAllRegions As Range
    Dim rRegion As Range
    Dim rDest As Range

    Set ws = ActiveWorkbook.ActiveSheet
    Set rAllRegions = GetAllPopulatedCells(ws)
    Set rDest = ws.Range("A16")

    If rAllRegions Is Nothing Then
        MsgBox "No populated cells found in '" & ws.Name & "'. Exiting Macro.", , "Error"
        Exit Sub
    End If

    For Each rRegion In rAllRegions.Areas
        rRegion.CopyPicture
        rDest.PasteSpecial
        Set rDest = rDest.Offset(rRegion.Rows.Count)
    Next rRegion

End Sub

Public Function GetAllPopulatedCells(Optional ByRef arg_ws As Worksheet) As Range

    Dim ws As Worksheet
    Dim rConstants As Range
    Dim rFormulas As Range

    If arg_ws Is Nothing Then Set ws = ActiveWorkbook.ActiveSheet Else Set ws = arg_ws

    On Error Resume Next
    Set rConstants = ws.Cells.SpecialCells(xlCellTypeConstants)
    Set rFormulas = ws.Cells.SpecialCells(xlCellTypeFormulas)
    On Error GoTo 0

    Select Case Abs(rConstants Is Nothing) + 2 * Abs(rFormulas Is Nothing)
        Case 0: Set GetAllPopulatedCells = Union(rConstants, rFormulas)
        Case 1: Set GetAllPopulatedCells = rFormulas
        Case 2: Set GetAllPopulatedCells = rConstants
        Case 3: Set GetAllPopulatedCells = Nothing
    End Select

    Set ws = Nothing
    Set rConstants = Nothing
    Set rFormulas = Nothing

End Function

如何遍历工作表的多个区域？

2 个答案: