从数组创建新工作表

Question

我有一份工作sheet，其中包含一些数据。我将该数据存储在一个数组中，然后我想创建一个新作品sheet并将数据保存到一个新作品sheet.

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

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

在新工作簿中复制 sheet 内容的最有效方法应该是下一个：

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

从数组创建新工作表

Creating new worksheet from array

excel

vba