我编写了以下代码，它通过我的主工作簿的工作表进行迭代，检查条件，然后如果满足条件，则将活动工作表复制到新工作簿中并保存。但是，我想将工作表附加到另一个笔记本上。
Sub Archive_Sheets()
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
Dim SrchRng As Range, cel As Range
Set SrchRng = ws.Range("C9:C108")
Dim bought_amt As Integer
Dim called_amt As Integer
bought_amt = 0
called_amt = 0
For Each cel In SrchRng
If InStr(1, cel.Value, "BOUGHT") > 0 Then
bought_amt = bought_amt + cel.Offset(0, 1).Value
End If
If InStr(1, cel.Value, "CALLED") > 0 Then
called_amt = called_amt + cel.Offset(0, 1).Value
End If
Next cel
If called_amt = bought_amt Then
ws.Range("A1").Value = "DONE"
Module8.CopySheet
Exit For
'ws.Delete
End If
Next
End Sub
Sub CopySheet()
Application.DisplayAlerts = False
Dim wb_name_arr() As String
pName = ActiveWorkbook.Path
wbName = ActiveWorkbook.Name ' the file name of the currently active file
shtName = ActiveSheet.Name ' the name of the currently selected worksheet
wb_name_arr() = Split(wbName, ".")
Application.ScreenUpdating = False
ActiveSheet.Select
ActiveSheet.Copy
' NEED TO CHANGE THIS LINE ********************
ActiveSheet.SaveAs Filename:=pName + "\" + wb_name_arr(0) + " archived.xlsx"
'****************************
Application.ScreenUpdating = True
End Sub
上面的代码会覆盖我保存的新工作簿，因此它只是最新的工作表。我已经创建了这个工作簿，所以如果我可以将活动工作表添加到它是理想的。我已经尝试了
ActiveSheet.Copy After:=Workbook(pName + "\" + wb_name_arr(0) + " archived.xlsx")
和
ActiveSheet.Copy Before:=Workbooks.Open(pName + "\" + wb_name_arr(0) + " archived.xlsx").Sheets(0)
没有运气。
答案 0 :(得分：1)
尝试这样的事情（暂时让它变得简单，我在开始时插入表格）：
ActiveSheet.Copy Before:=Workbooks(wb_name_arr(0) & " archived.xlsx").sheets(1)
如果目标WB 已经打开，则此方法有效。如果尚未打开，您可能需要打开WB。使用以下子项创建或打开目标WB：
Sub archiveSheet(ws as Worksheet)
Dim destName As String
destName = left(ThisWorkbook.name, InStrRev(ThisWorkbook.name, ".") - 1) & " archived.xlsx"
Application.DisplayAlerts = False: Application.ScreenUpdating = False
On Error Resume Next
Dim destWB As Workbook: Set destWB = Workbooks(destName)
If destWB Is Nothing Then Set destWB = Workbooks.Open(ThisWorkbook.path + "\" & destName)
If destWB Is Nothing Then
Set destWB = Workbooks.Add
destWB.SaveAs ThisWorkbook.path & "\" & destName
End If
If destWB Is Nothing Then
msgBox "could not open or create " & destName
Else
ws.Copy After:=destWB.Sheets(destWB.Sheets.count)
End If
Application.DisplayAlerts = True: Application.ScreenUpdating = True
End Sub
从主程序Archive_Sheets中调用它，如下所示：
archiveSheet ws
答案 1 :(得分：1)
这些行是伪代码。一般的想法是Implicit None。尝试明确引用工作簿和工作表而不是激活它们。哪个也快。
尽量避免在代码中使用ActiveSheet。只需尝试这样的事情：
Set mySht = ActiveSheet 'This should be set at the beginning of your code
然后，只要您的代码中有该工作表（即ActiveSheet），请改用oSht。
因此，您需要打开Workbook才能使用它。同样，您可以为不同的工作簿指定名称，如下所示：
Set myWbk = ActiveWorkbook
'Or
Set oWbk = Workbooks("Output.xlsx")
@ A.S.H建议然后为你工作：
oFile = "Path/to/the/File/" & wb_name_arr(0) & " archived.xlsx"
Set oWbk = Workbooks.Open(oFile)
mySht.Copy Before:=Workbooks(oWbk).sheets(1)
答案 2 :(得分：1)
Private Sub that()
Dim aRR As Variant
aRR = ThisWorkbook.Sheets("Sheet1").UsedRange
Dim colC As Long
Dim rowC As Long
colC = ThisWorkbook.Sheets("Sheet1").UsedRange.Columns.Count
rowC = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count
ThisWorkbook.Sheets("Sheet2").Range(ThisWorkbook.Sheets("Sheet2").Cells(1, 1), ThisWorkbook.Sheets("Sheet2").Cells(rowC, colC)).Value2 = aRR
End Sub
答案 3 :(得分：1)
尝试编辑过的代码（我已对两个Sub进行了编辑，使其更短，并且更快，因为无需使用Select和Activate）。
代码中的注释为注释。
Option Explicit
Sub Archive_Sheets()
Dim SrchRng As Range, cel As Range
Dim bought_amt As Long
Dim called_amt As Long
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
With ws
Set SrchRng = .Range("C9:C108")
bought_amt = 0
called_amt = 0
For Each cel In SrchRng
If cel.Value Like "BOUGHT*" Then
bought_amt = bought_amt + cel.Offset(0, 1).Value
End If
If cel.Value Like "CALLED*" Then
called_amt = called_amt + cel.Offset(0, 1).Value
End If
Next cel
If called_amt = bought_amt Then
.Range("A1").Value = "DONE"
CopySheet .Name ' <-- call the function and send the current ws sheet's name
Exit For
End If
End With
Next
End Sub
'==================================================================
Sub CopySheet(wsName As String)
Application.DisplayAlerts = False
Dim wb_name_arr() As String
Dim wb As Workbook
Dim pName As String, wbName As String
pName = ActiveWorkbook.Path
wb_name_arr() = Split(wbName, ".")
Application.ScreenUpdating = False
On Error Resume Next
Set wb = Workbooks(wb_name_arr(0) & " archived.xlsx") ' try to set wb if it's already open
On Error GoTo 0
If wb Is Nothing Then ' <-- wb is Nothing, means it's still close, open it
Set wb = Workbooks.Open(Filename:=pName & "\" & wb_name_arr(0) & " archived.xlsx")
End If
' === Copy the sheet to "archived" file one before tha last sheet ===
Worksheets(wsName).Copy before:=wb.Sheets(wb.Sheets.Count)
Application.ScreenUpdating = True
End Sub
答案 4 :(得分：1)
解决问题的完整代码。
Sub Archive_Sheets()
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
Dim SrchRng As Range, cel As Range
Set SrchRng = ws.Range("C9:C108")
Dim bought_amt As Integer
Dim called_amt As Integer
bought_amt = 0
called_amt = 0
For Each cel In SrchRng
If InStr(1, cel.Value, "BOUGHT") > 0 Then
bought_amt = bought_amt + cel.Offset(0, 1).Value
End If
If InStr(1, cel.Value, "CALLED") > 0 Then
called_amt = called_amt + cel.Offset(0, 1).Value
End If
Next cel
If called_amt = bought_amt Then
If called_amt <> 0 Then
ws.Range("A1").Value = "DONE"
Module8.CopySheet
'ws.Delete
End If
End If
Next
End Sub
Sub CopySheet()
Application.DisplayAlerts = False
Dim wb_name_arr() As String
pName = ActiveWorkbook.Path
wbName = ActiveWorkbook.Name ' the file name of the currently active file
shtName = ActiveSheet.Name ' the name of the currently selected worksheet
wb_name_arr() = Split(wbName, ".")
Set mySht = ActiveSheet 'This should be set at the beginning of your code
Set myWbk = ActiveWorkbook
oFile = pName & wb_name_arr(0) & " archived.xlsx"
Set oWbk = Workbooks.Open("path_to_file")
mySht.Copy after:=oWbk.Sheets(oWbk.Sheets.Count)
oWbk.Save
End Sub