Question

VBA新手在这里。很抱歉这个愚蠢的问题，但是我找不到我想要的答案。假设我有多个范围：

A9:A27
A31:A44
A49:A68

范围之间有空格。我必须将它们粘贴到一个新的工作表上，一个接一个地没有任何空格，以便以后可以将该数据表用作Pivot源。要注意的是，随着时间的流逝，我将来需要将新的数据行添加到这些范围，这意味着行号将发生变化，例如像这样：

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

在VBA中选择动态范围-如何为更改图纸中位置的范围调整代码？

2 个答案: