Как перебрать несколько областей листа? - PullRequest
0 голосов
/ 23 апреля 2019

Я ищу какой-то 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 = ""

Ответы [ 2 ]

0 голосов
/ 24 апреля 2019

Основная подпрограмма (я назвал ее 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
0 голосов
/ 24 апреля 2019

Нечто подобное должно работать

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 в приведенном ниже примере).

enter image description here

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...