我已经编译了一个宏，以根据原始工作簿中的唯一值生成新工作簿。然后，它将与thees值相关的行复制到新工作簿中。效果很好。
但是，我还希望在此过程之后复制模板，并将其作为新行插入到新工作簿中。我在激活此新工作簿以运行这些操作时遇到了麻烦。
我猜想新工作簿需要设置为某种东西，以便我可以以此为参考。稍后在本部分中使用：Windows("newBook").Activate。还是应该把这部分写得完全不同？
什么时候应该保存新工作簿以设置其名称？
使用这一部分ActiveWorkbook.SaveAs SavePath & ArrayOfUniqueValues(ArrayItem) & ".xlsx", 51
这是我到目前为止所拥有的：
Option Explicit
Sub DataExport()
'Declare variables
Dim ArrayItem As Long
Dim ws As Worksheet
Dim NewBook As Workbook
Dim ArrayOfUniqueValues As Variant
Dim SavePath As String
Dim ColumnHeadingInt As Long
Dim ColumnHeadingStr As String
Dim rng As Range
Set ws = Sheets("Data")
Set NewBook = 'what?
'The save path for the files created
SavePath = Range("FolderPath")
'Variables for the column to separate data based on
ColumnHeadingInt = WorksheetFunction.Match(Range("ExportCriteria").Value, Range("Data[#Headers]"), 0)
ColumnHeadingStr = "Data[[#All],[" & Range("ExportCriteria").Value & "]]"
'Turn off screen updating to save runtime
Application.ScreenUpdating = False
'Creates a temporary list of unique values
Range(ColumnHeadingStr & "").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("UniqueValues"), Unique:=True
'Sort the temporary list of unique values
ws.Range("UniqueValues").EntireColumn.Sort Key1:=ws.Range("UniqueValues").Offset(1, 0), _
Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Add unique field values into an array
ArrayOfUniqueValues = Application.WorksheetFunction.Transpose(ws.Range("UniqueValues").EntireColumn.SpecialCells(xlCellTypeConstants))
'Delete the temporary values
ws.Range("UniqueValues").EntireColumn.Clear
'Loop through the array of unique field values. Then copy paste into new workbooks and save.
For ArrayItem = 1 To UBound(ArrayOfUniqueValues)
ws.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)
ws.Range("Data[#All]").SpecialCells(xlCellTypeVisible).Copy
Workbooks.Add
Range("A1").PasteSpecial xlPasteAll ' pastes all values
Columns(1).EntireColumn.Delete
'saving the new workbook. Should it be places somewhere else?
ActiveWorkbook.SaveAs SavePath & ArrayOfUniqueValues(ArrayItem) & ".xlsx", 51
'here is where the trouble starts
Windows("REFERENCE with export VB.xlsm").Activate
Sheets("Template").Select
Rows("1:5").Select
Selection.Copy
'Now the tricky part on how to go back to the new workbook
Windows("newBook").Activate
Rows("1:1").Select
Selection.Insert Shift:=xlDown
'Saving and closing
ActiveWorkbook.Save
ActiveWorkbook.Close False
ws.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt
Next ArrayItem
ws.AutoFilterMode = False
MsgBox "Finished exporting!"
Application.ScreenUpdating = True
End Sub
答案 0 :(得分：0)
我试图解释代码，因此很有意义。我不知道您实际上要如何处理工作表模板中复制的行，我假设您想将该格式粘贴到新工作簿的前5行中...
Option Explicit
Sub DataExport()
'Turn off screen updating to save runtime
Application.ScreenUpdating = False 'do it at the beginning of your code
'Declare variables
'try to declare your variables just before using them so it's easier to know what do they do.
'Dim rng As Range you are not using this
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Data") 'always reference workbook and worksheet
'The save path for the files created
Dim SavePath As String
SavePath = Range("FolderPath")
With ws 'you can use this to reference this worksheet using only a dot
'Variables for the column to separate data based on
Dim ColumnHeadingInt As Long
ColumnHeadingInt = WorksheetFunction.Match(.Range("ExportCriteria").Value, .Range("Data[#Headers]"), 0)
Dim ColumnHeadingStr As String
ColumnHeadingStr = "Data[[#All],[" & .Range("ExportCriteria") & "]]"
'Creates a temporary list of unique values
.Range(ColumnHeadingStr & "").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Range("UniqueValues"), Unique:=True
'Sort the temporary list of unique values
.Range("UniqueValues").EntireColumn.Sort Key1:=ws.Range("UniqueValues").Offset(1, 0), _
Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Add unique field values into an array
Dim ArrayOfUniqueValues As Variant
ArrayOfUniqueValues = Application.WorksheetFunction.Transpose(.Range("UniqueValues").EntireColumn.SpecialCells(xlCellTypeConstants))
'Delete the temporary values
.Range("UniqueValues").EntireColumn.Clear
End With 'here ends the reference to your ws sheet
'You shouldn't declare anything inside a loop, so you do it just before.
Dim NewBook As Workbook
'Loop through the array of unique field values. Then copy paste into new workbooks and save.
Dim ArrayItem As Long
For ArrayItem = LBound(ArrayOfUniqueValues) To UBound(ArrayOfUniqueValues)
.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)
.Range("Data[#All]").SpecialCells(xlCellTypeVisible).Copy
'Here you use the NewBook variable.
Set NewBook = Workbooks.Add 'you can use the workbook variable like this
With NewBook.Sheets(1)
.Range("A1").PasteSpecial xlPasteAll ' pastes all values
.Columns(1).EntireColumn.Delete
.Rows("1:1").Insert Shift:=xlDown
End With
'here is where the trouble starts this block can be resumed in one line of code
' Windows("REFERENCE with export VB.xlsm").Activate
' Sheets("Template").Select
' Rows("1:5").Select
' Selection.Copy
'ThisWorkbook always refers to the workbook running the code
ThisWorkbook.Sheets("Template").Rows("1:5").Copy
With NewBook 'again reference the new workbook
'This I think is what you want to do, paste formats from rows 1 to 5 on your Template sheet
.Sheets(1).Range("A1").PasteSpecial xlPasteFormats
'saving the new workbook. Should it be places somewhere else?
'Should be placed just before the last operation so you don't need to save multiple times
.SaveAs SavePath & ArrayOfUniqueValues(ArrayItem) & ".xlsx", 51
.Close
End With
ws.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt
Next ArrayItem
ws.AutoFilterMode = False
MsgBox "Finished exporting!"
Application.ScreenUpdating = True
End Sub