VBA - 将动态范围复制到新工作簿

Question

我试图弄清楚如何将动态范围复制到新工作簿中。实际项目是根据用户对月份的选择生成每月预算报告。总体系统跟踪多个预算项目，其中每一行都有自己的工作表，每个工作表在本财政年度保留12个表格，用于输入费用;这一切都反馈到年度预算表中。在用户选择一个月后，将创建一个新工作簿，镜像页数并用该月份表填充每个工作表。每张表都是动态范围。

我在下面的内容是运行机制，但问题是我无法正确粘贴动态范围：

Sub pasting()

On Error Resume Next

Dim x As Workbook
Dim y As Workbook

'set the budget tracking system as the active workbook
Set x = Workbooks("Save and copying proof of concept.xlsm")

'activate budget tracking system
x.Activate

Set y = Workbooks.Add

Dim z As Range
Dim w As Range


'test copying two cells in two sheets into new sheets in the new workbook
Set z = Workbooks("Save and copying proof of concept.xlsm").Sheets("Sheet1").Range("A1")
Set w = Workbooks("Save and copying proof of concept.xlsm").Sheets("Sheet2").Range("A1")

'call saveas option for monthly workbook
With y
    Call save_workbook_newName
End With

'add 8 sheets to new workbook for 8 budget lines
Dim v As Worksheet
Dim i As Integer

For i = 1 To 7
   Sheets.Add

Next i

'copy the specified range from the original sheet and into the newly created workbook.

z.Copy
y.Sheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteValues

w.Copy
y.Sheets("Sheet2").Range("A1").PasteSpecial Paste:=xlPasteValues

'copy a dynamic range to a new workbook

x.Worksheets("Sheet3").Activate

Dim xRow As Long, xColumn As Long

'determine the row and column limits of the dynamic range
Range("A100").End(xlUp).Select
xRow = ActiveCell.Row

Range("D").End(xlToLeft).Activate
xColumn = ActiveCell.Column

'select the range specified by the dynamic boundaries
Range(Cells(1, 1), Cells(xRow, xColumn)).Select

Selection.Copy

'activate newly created workbook
y.Worksheets("Sheet3").Activate

'paste into the new workbook
Selection.PasteSpecial Paste:=xlPasteAll, operation:=xlNone, SkipBlanks:=False, _
    Transpose:=False

End Sub



Sub save_workbook_newName()

    Dim workbook_name As Variant

    'display the SaveAs dialog box
    'once a name is provided, the GetSaveAsFilename method gets the particular name and _
    'assigns that name to the workbook_name variable

    workbook_name = Application.GetSaveAsFilename

    'if the user provides a filename, the true condition is executed, and if not (presses Cancel), the false condition is executed.
    If workbook_name <> False Then

    'the application.acriveworkbook property returns the workbooks to the current active window
    'saves the file with the file name given by the user.

        ActiveWorkbook.SaveAs Filename:=workbook_name & "xlsx"
    Else
        ActiveWorkbook.Close
    End If

End Sub

这一位是有问题的代码：

Range("A100").End(xlUp).Select
xRow = ActiveCell.Row

Range("D").End(xlToLeft).Activate
xColumn = ActiveCell.Column

'select the range specified by the dynamic boundaries
Range(Cells(1, 1), Cells(xRow, xColumn)).Select

它基本上只复制A列，即使它被告知激活D列并选择左侧的所有内容（A列到C列保留随机数）。

使用此方法选择动态范围并未产生良好效果：

LR = Range("D1000").End(xlUp).Row
Set R1 = Range("D1:E" & LR)

谢谢，我感谢你在这方面的帮助！

Answer 1

Range对象可以使用两个参数Range([Cell1],[Cell2)。从字面上看，您将左上角的单元格用作第一个参数，将右下角的单元格用作第二个参数。

代码的第一个参数是Cells(1, 1)，第二个参数是Cells(xRow, xColumn)。范围将从Row 1 Column 1延伸到Row xRow, Column xColumn。

  

范围（单元格（1,1），单元格（xRow，xColumn））

复制和粘贴时无需选择范围。我们可以将范围方法连在一起。

这里我们设置一个范围，从D100开始，一直延伸到最左边的列，然后一直到列表中最后一个使用过的单元格。然后我们将其复制并粘贴到y.Worksheets("Sheet3").Range("A1")。

敌人的例子：

Dim rw As Long, Cell1 As Range, Cell2 As Range
Dim y As Workbook
Set x = Workbooks.Add
Set y = Workbooks("Book5.xlms")
rw = 100
Set Cell1 = Range("A" & rw)
Set Cell2 = Range("A" & rw).End(xlToRight).End(xlDown)    'This is the bottom left cell in the table
Set Target = Range(Cell1, Cell2)
Target.Copy x.Worksheets("Sheet1").Range("A1")

我们可以像这样在一行完成所有这些：

rw = 100
Range("D" & rw, Range("D" & rw).End(xlToRight).End(xlDown)).Copy y.Worksheets("Sheet3").Range("A1")

Answer 2

使用.Resize的另一种方法。我认为这种方法比@Thomas Inzina好一点，因为它沿着列和行标题（.End方法），可能没有空单元格。在Thomas的例子中，如果您的数据在最后一列中有空单元格，则代码将复制不完整的表格。

Sub copyTableIntoNewWorksheet()

    ' locate the dynamic range / table
    Dim rngTable As Range
    With ActiveSheet.[b2]    ' top left cell of the dynamic range
        Set rngTable = .Resize(Range(.Offset(0), .End(xlDown)).Rows.Count, _
                               Range(.Offset(0), .End(xlToRight)).Columns.Count)
    End With

    ' create new worksheet
    Dim wsNew As Worksheet
    Set wsNew = Worksheets.Add
    wsNew.Name = "New Sheet"

    ' copy table to new worksheet
    rngTable.Copy wsNew.[a1] ' top left cell where to copy the table to

End Sub