如何使用VBA复制基于名称的Excel表单？

的背景：

• 我有一个包含多个工作簿的目录。
• 每个工作簿包含多个工作表，隐藏和可见。
• 我想将每个工作簿中的一个特定工作表复制到现有的主工作簿中。

问题：

• 目前，我的代码复制每个源工作簿中的第一个工作表。
• 我需要代码才能复制名为“[当前月份]摘要”的表单，这通常不是源工作簿中的第一个工作表。
• 由于[当前月份]会发生变化，因此需要复制姓名的最后七个字母为“摘要”的工作表。

我的代码如下：

Dim wbDst As Workbook Dim wbSrc As Workbook Dim wsSrc As Worksheet Dim MyPath As String Dim strFilename As String Application.DisplayAlerts = False Application.AskToUpdateLinks = False Application.EnableEvents = False Application.ScreenUpdating = False MyPath = InputBox("Please copy and paste the path to the folder containing the source documents") Set wbDst = ActiveWorkbook strFilename = Dir(MyPath & "\*.xls", vbNormal) If Len(strFilename) = 0 Then Exit Sub Do Until strFilename = "" Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename) Set wsSrc = wbSrc.Worksheets(1) wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count) wbSrc.Close False strFilename = Dir() Loop 

Answer 1

replace这一行

 Set wsSrc = wbSrc.Worksheets(1) 

同

 Set wsSrc = wbSrc.Worksheets("[current month] Summary") 

编辑：

把你目前的Do Until Codereplace成下面的:)

 Do Until strFilename = "" Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename) For Each ws In wbSrc.Worksheets If InStr(1, ws.Name, "summary", vbTextCompare) Then Set wsSrc = ws End If Next ws wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count) wbSrc.Close False strFilename = Dir() Loop 

Answer 2

下面的代码将获得当前的月份，并在工作簿中检查名称后会给你想要的结果：

 Dim currMonth As String currMonth = MonthName(Month(Now)) Do Until strFilename = "" Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename) For Each ws In wbSrc.Worksheets If ws.Name = currMonth & "Summary" Then Debug.Print ws.Name Set wsSrc = ws wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count) Exit For End If Next wbSrc.Close False strFilename = Dir() Loop