从数组创建新的工作表

Question

我有一些数据的工作表。我将数据存储在一个数组中，然后我想创建一个新的工作表并将数据保存到一个新的工作表中。

现在我在原始数据的工作簿中创建一个新工作表，如下所示:

Sub New_workbook()
Dim sh as Worksheet, origin as Worksheet, arr
origin = Sheets("OriginSheet")
sh = ActiveSheet
somedata = origin.Range("A1:C").Value
ReDim arr(1 To 100, 1 To 3)

For i = 1 To 100
arr(i, 1) = somedata(i, 1)
arr(i, 2) = somedata(i, 2)
arr(i, 3) = somedata(i, 3)
Next i
sh.Range("A2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub

而不是sh = ActiveSheet，我想有像sh = NewWorkbook("Name_of_new_workbook")的东西，并在OriginSheet工作簿或给定路径的目录中创建一个工作簿，并用arr值填充它。我怎么能做到这一点在VBA?

Answer 1

如果您希望复制源范围中的所有数据，则没有必要首先将该数据存储在数组中。只需Set您的范围，并使目标范围的值等于源范围的值。试试这样做:

Sub CopyRangeIntoNewWorkbook()
'disabling screen update and calculation to speed things up
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook, wb_new As Workbook
Dim ws As Worksheet
Dim rng As Range
Set wb = ActiveWorkbook
Set ws = ActiveSheet
'set the rng for which you want to copy the values
Set rng = ws.Range("A1:C10")
'set wb_new to newly added wb
Set wb_new = Workbooks.Add()
'specify the top left cell of the range you want to have populated in the new wb
wb_new.Sheets(1).Range("A1").Resize(rng.Rows.Count, rng.Columns.Count).Value2 = rng.Value2
'save file, here using path of your original wb'
wb_new.SaveAs Filename:=wb.path & "wb_new.xlsx"
'closing the new file
wb_new.Close saveChanges:=False
'enabling screen update and automatic calculation again
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Answer 2

在新工作簿中复制工作表内容的最有效方法应该是:

Sub New_workbook()
Dim origin As Worksheet
Set origin = Sheets("OriginSheet") 'an object must be Set
origin.Copy 'this will create a new workbook with the content of the copied sheet
ActiveWorkbook.saveas origin.Parent.path & "" & "Name_of_new_workbook" & ".xlsx", xlWorkbookDefault
End Sub

如果只需要保留"A:C"列，可以添加下面的代码行:

Dim sh As Worksheet, lastCol As Long
Set sh = ActiveWorkbook.Worksheets(1)
lastCol = sh.cells.SpecialCells(xlCellTypeLastCell).Column
If lastCol <= 3 Then Exit Sub
If lastCol = 4 Then sh.cells(1, 4).EntireColumn.Delete: Exit Sub
sh.Range(sh.cells(1, 4), sh.cells(1, lastCol)).EntireColumn.Delete