如果名称中包含某个单词，则将其从一个工作簿复制并粘贴到另一个工作簿

有人能够build议在下面？ 我试图编写一个代码来复制名称中包含几个工作簿RTP的工作表。 我到了下面的代码，但是当我尝试运行它基本上崩溃了我的Excel。 我会很感激的build议，如果这是完全错误的，请让我知道，我会重新开始！

Sub RTP_reporting() Dim WorkbookName As String WorkbookName = Format(Date, "dd-mm-yyyy") Workbooks.Add ActiveWorkbook.SaveAs Filename:="New RTP report" Workbooks.Open Filename:="https://addresshere" ActiveWorkbook.Unprotect Password:="xxx" Workbooks.Open Filename:="https://addresshere2" ActiveWorkbook.Unprotect Password:="xxx" 

等等，为9个文件。

 Dim ws As Worksheet For Each ws In Sheets If LCase(ws.Name) Like "*RTP*" Then ws.Select End If Next Windows("New RTP report.xlsx").Activate Workbooks("New RTP report.xlsx").Paste ActiveWorkbook.SaveAs Filename:="RTP_report_" & WorkbookName 

然后我想保护以前打开的工作簿并closures它们。

 Windows("File1.xlsm").Activate ActiveWorkbook.Protect Password:="xxx" ActiveWindow.Close Windows("File2.xlsm").Activate ActiveWorkbook.Protect Password:="xxx" ActiveWindow.Close End Sub 

Answer 1

看看这个。

我添加了Workbook对象来Set wb1 = Workbooks.Open("addresshere")引用（ Set wb1 = Workbooks.Open("addresshere") ），并清理了一下你的代码，那应该可以了！ ;）

 Sub RTP_reporting() Dim WorkbookName As String, _ wbRep As Workbook, _ wb1 As Workbook, _ wb2 As Workbook, _ ws As Worksheet WorkbookName = Format(Date, "dd-mm-yyyy") Set wbRep = Workbooks.Add wbRep.SaveAs Filename:="New RTP report" Set wb1 = Workbooks.Open("https://addresshere") wb1.Unprotect Password:="xxx" Set wb2 = Workbooks.Open("https://addresshere2") wb2.Unprotect Password:="xxx" For Each ws In wb1.Sheets If InStr(1, LCase(ws.Name), "rtp") > 0 Then ws.Copy after:=wbRep.Sheets(wbRep.Sheets.Count) End If Next For Each ws In wb2.Sheets If InStr(1, LCase(ws.Name), "rtp") > 0 Then ws.Copy after:=wbRep.Sheets(wbRep.Sheets.Count) End If Next ws wbRep.SaveAs Filename:="RTP_report_" & WorkbookName wb1.Protect Password:="xxx" wb1.Close wb2.Protect Password:="xxx" wb2.Close Set wbRep = Nothing Set wb1 = Nothing Set wb2 = Nothing End Sub 

Answer 2

我个人不喜欢在我的VBA代码中使用Active...函数和Activate和Select方法，因为它可能导致无法解释的应用程序错误和崩溃。 相反，我把我想要使用的对象与一个variables

 Dim Report as Workbook set Report = Workbooks.Add ... Report.SaveAs ... 

为源工作簿做同样的事情

 dim Source as Workbook set Source = Workbooks.Open ... 

现在循环遍历工作表，而不是select和复制，直接复制工作表到所需的工作簿

 For Each ws in Source.sheets If ... ws.copy Before:= Report.Sheets(1) End If .. Loop 

希望这会指向你正确的方向。