Excel VBA-從外部工作簿將特定工作表導入工作簿

Question

我能夠利用其他人的代碼從外部工作簿導入工作表，但是代碼要求我手動更改工作表名稱。

我目前在工作簿A中有一個列，其名稱是每個（約20）工作表，我試圖從工作簿B（其中有數百個工作表）中提取。有沒有辦法循環此代碼並引用工作簿A中的列以更改我的宏中的工作表名稱從工作簿B中拉出？下面 代碼（假設WORKSHEET1是我從工作簿乙拉工作表的名稱）

Sub ImportSheet() 
Dim sImportFile As String, sFile As String 
Dim sThisBk As Workbook 
Dim vfilename As Variant 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
Set sThisBk = ActiveWorkbook 
sImportFile = Application.GetOpenFilename(_ 
FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", Title:="Open Workbook") 
If sImportFile = "False" Then 
    MsgBox "No File Selected!" 
    Exit Sub 

Else 
    vfilename = Split(sImportFile, "\") 
    sFile = vfilename(UBound(vfilename)) 
    Application.Workbooks.Open Filename:=sImportFile 

    Set wbBk = Workbooks(sFile) 
    With wbBk 
     If SheetExists("WORKSHEET1") Then 
      Set wsSht = .Sheets("WORKSHEET1") 
      wsSht.Copy before:=sThisBk.Sheets("Sheet1") 
     Else 
      MsgBox "There is no sheet with name :WORKSHEET1 in:" & vbCr & .Name 
     End If 
     wbBk.Close SaveChanges:=False 
    End With 
End If 
Application.ScreenUpdating = True 
Application.DisplayAlerts = True 
End Sub 
Private Function SheetExists(sWSName As String) As Boolean 
Dim ws As Worksheet 
On Error Resume Next 
Set ws = Worksheets(sWSName) 
If Not ws Is Nothing Then SheetExists = True 

端功能

Answer 1

編輯嘗試以下。

Sub ImportSheet() 
    Dim sImportFile As String, sFile As String 
    Dim wbThisWB As Workbook 
    Dim wbTheOtherWB As Workbook 
    Dim vfilename As Variant 
    Dim WSName As String 
    Dim LastRow As Long 

    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 

    Set wbThisWB = ThisWorkbook 
    LastRow = wbThisWB.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 'get the last row whith sheets names 

    sImportFile = Application.GetOpenFilename(_ 
    FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", Title:="Open Workbook") 

    If sImportFile = "False" Then 
     MsgBox "No File Selected!" 
     Exit Sub 

    Else 
     vfilename = Split(sImportFile, "\") 
     sFile = vfilename(UBound(vfilename)) 
     Application.Workbooks.Open Filename:=sImportFile 

     Set wbTheOtherWB = Workbooks(sFile) 

     With wbTheOtherWB 
      For i = 1 To LastRow 'rows in current workbook with worksheets names 
       WSName = wbThisWB.Worksheets("Sheet1").Cells(i, 1) 'where you place sheets names (here column A, from row 1 down) 
       If sheetExists(WSName, wbTheOtherWB) Then 
        Set wsSht = .Sheets(WSName) 
        wsSht.Copy before:=wbThisWB.Sheets("Sheet1") 
       Else 
        MsgBox "There is no sheet with name : " & WSName & " in:" & vbCr & .Name 
       End If 
      Next 
      wbTheOtherWB.Close SaveChanges:=False 
     End With 
    End If 
    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
End Sub 

Function sheetExists(sheetToFind As String, wbTheOtherWB As Workbook) As Boolean 
    sheetExists = False 
    For Each Sheet In wbTheOtherWB.Worksheets 
     If sheetToFind = Sheet.Name Then 
      sheetExists = True 
      Exit Function 
     End If 
    Next Sheet 
End Function