在关闭的工作簿中搜索具有特定名称的工作表，然后将该工作表复制到活动工作簿中

Question

我有一个代码当前打开了名为"Specification and Configuration Document.xlsx"的已关闭工作簿，现在我需要它来查找此已关闭工作簿中具有值wsName的任何工作表，该值随着for循环的进行而更改。此代码的主要部分在名为"SD093_W.xlsm"的活动工作簿中操作，sysnum变量是在代码循环通过E列搜索唯一值时生成的。如果找到一个唯一的值，那么它会查看与列E同一行的列D单元格，并读取然后分配给变量wsName的值。

一旦确定了wsName值，我需要代码在关闭的工作簿"Specification and Configuration Document.xlsx"中查找并复制wsName。例如，假设在活动工作簿中找到的wsName是Test2，那么我想进入关闭的工作簿，搜索标题为Test2的工作表，复制它，然后将它粘贴到活动工作簿中，并将其重命名为sysnum值。

到目前为止，我的代码就是这样的：任何帮助都将不胜感激。

Global sysrow As Integer, sysnum As String, wsName As String
Public Sub Main()
Dim wb As Workbook, ws As Worksheet, i As Range, dict As Object ', wsName As String
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
Set dict = CreateObject("scripting.dictionary")
For Each i In ws.Range("E2:E15").Cells ' i = every WD number
sysnum = i.value
sysrow = i.Row
syscol = i.Column
If sysnum = "" Then
On Error Resume Next
End If
If Not dict.Exists(sysnum) Then ' check if unique value already exists before adding it to dictionary
dict.Add sysnum, True
If Not SheetExists(sysnum) Then
wsName = i.EntireRow.Columns("D").value ' sheet to be copied
If SheetExists(wsName) Then ' if there is a sheet for wsName to copy
wb.Worksheets(wsName).Copy After:=ws ' copy the sheet
wb.Worksheets(ws.Index + 1).name = sysnum ' rename the copy
End If
Else
MsgBox "Sheet " & sysnum & " already exists"
End If
End If
specmin = Application.Match("SPEC min", Worksheets(sysnum).Range("A2:Q2"), 0) ' column index for SPEC min in SD tab
IsError (specmin)
specmax = Application.Match("SPEC max", Worksheets(sysnum).Range("A2:Q2"), 0) ' column index for SPEC max in SD tab
IsError (specmax)
formula = Application.Match("Formula / step size", Worksheets(sysnum).Range("A2:Q2"), 0)
IsError (formula)
Next i
End Sub

---

' check does a sheet named wsName exist in default current Workbook
Function SheetExists(SheetName As String)
Dim wb As Workbook, filepath As String
filepath = "Specification and Configuration Document.xlsx"
If wb Is Nothing Then Set wb = Workbooks.Open(filename:=filepath) 'ThisWorkbook
On Error Resume Next
SheetExists = Not wb.Sheets(SheetName) Is Nothing
End Function

Answer 1

根据上面的评论：

Dim sysrow As Long, syscol As Long, sysnum As String, wsName As String
Public Sub Main()
Dim wb As Workbook, ws As Worksheet, i As Range, dict As Object ', wsName As String
Dim wbSrc As Workbook

Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")

'pass the full path and filename, or (eg) use `Thisworkbook.Path`
Set wbSrc = Workbooks.Open("C:TempSpecification and Configuration Document.xlsx")

Set dict = CreateObject("scripting.dictionary")
For Each i In ws.Range("E2:E15").Cells ' i = every WD number
sysnum = i.Value
sysrow = i.Row
syscol = i.Column
If Len(sysnum) > 0 Then
If Not dict.Exists(sysnum) Then
dict.Add sysnum, True
If Not SheetExists(sysnum, wb) Then
wsName = i.EntireRow.Columns("D").Value ' sheet to be copied
If SheetExists(wsName, wbSrc) Then ' if there is a sheet for wsName to copy
wbSrc.Worksheets(wsName).Copy After:=ws ' copy the sheet
wb.Worksheets(ws.Index + 1).Name = sysnum ' rename the copy
End If 'wsName sheet exists
Else
MsgBox "Sheet " & sysnum & " already exists"
End If   'sysnum sheet exists
End If       'new sysnum value
'....
End If 'sysnum not zero-length

Next i
End Sub
'Does a sheet named `wsName` exist in Workbook `wb` ?
Function SheetExists(SheetName As String, wb As Workbook)
On Error Resume Next
SheetExists = Not wb.Sheets(SheetName) Is Nothing
End Function