Выбор динамического диапазона в VBA - Как настроить код для диапазона, который меняет местоположение на листе?

Question

VBA новичок здесь.Извините за глупый вопрос, но я просто не могу найти ответ, который ищу.Допустим, у меня есть несколько диапазонов:

A9:A27
A31:A44
A49:A68

с пробелами между диапазонами.Я должен вставить их на новый лист, один за другим, без пробелов, чтобы впоследствии этот лист можно было использовать в качестве источника сводной таблицы.Суть в том, что со временем мне нужно будет добавить новые строки данных в эти диапазоны в будущем, что означает, что номера строк будут меняться, например, так:

A9:A29
A33:A48
A53:A72

Верхний диапазон легко, так какверхний ряд останется неизменным, но как мне перейти на другие диапазоны?В настоящее время код для второго диапазона выглядит следующим образом:

copysheet.Range("A9").End(xlDown).Offset(4,0).Select
copysheet.Range(ActiveCell, ActiveCell.End(xlDown)).Copy
pastesheet.Cells(Rows.Count, 1).End(xlUp).Offset(1,0).PasteSpecial xlPasteValues

Моя проблема заключается в том, что мне придется вставлять данные из другой рабочей книги, поэтому я хочу избегать активации рабочих книг и использования ActiveCell и подобных.Я уверен, что есть более простой и чистый способ сделать это?

Answer 1

Если бы я был ленивым (что я и есть), я бы не стал помещать .End(xlDown) в цикл Do While, чтобы найти все куски вручную, и вместо этого делал бы

Dim r As Range ' Declare a variable to hold the result

' Limiting ourselves only to the used portion of the column A...
With Application.Intersect(copysheet.Range("A:A"), copysheet.UsedRange)
  On Error Resume Next 'Ignore errors because unfortunately SpecialCells throws errors when it does not find anything
  Set r = .SpecialCells(xlCellTypeConstants) ' Find all cells with regular non-formula values
  If r Is Nothing Then ' If there are no such cells
    Set r = .SpecialCells(xlCellTypeFormulas) ' Find all cells with formulas instead
  Else ' Otherwise, if there were cells with regular values
    Set r = Application.Union(r, .SpecialCells(xlCellTypeFormulas)) ' Also find cells with formulas and make it a single range with the previously found non-formula range
  End If
  On Error GoTo 0 ' Stop ignoring errors because we're done with SpecialCells
End With

If Not r Is Nothing Then ' If we found at least someting
  r.Copy ' Copy it
  pastesheet.Cells(pastesheet.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues ' and paste to destination
  Application.CutCopyMode = False ' then remove than annoying selection marquee
End If

Answer 2

Начинается с трех фиксированных начальных точек в столбце A , определяет размеры трех связанных блоков и копирует блоки в Sheet2:

Sub copyBLOCKS()
    Dim r1 As Range, r2 As Range, r3 As Range
    Dim r1x As Range, r2x As Range, r3x As Range
    Dim N As Long

    Set r1 = Range("A9")
    Set r2 = Range("A31")
    Set r3 = Range("A49")
    N = 1

    Range(r1, r1.End(xlDown)).Copy Sheets("Sheet2").Range("A" & N)
    N = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1

    Range(r2, r2.End(xlDown)).Copy Sheets("Sheet2").Range("A" & N)
    N = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1

    Range(r3, r3.End(xlDown)).Copy Sheets("Sheet2").Range("A" & N)

End Sub