Excel VBA - Importieren bestimmter Arbeitsblätter in eine Arbeitsmappe von einer externen Arbeitsmappe

Question

Ich konnte anderen Code verwenden, um ein Arbeitsblatt aus einer externen Arbeitsmappe zu importieren, jedoch erfordert der Code, dass ich den Arbeitsblattnamen manuell ändere.

Ich habe derzeit eine Spalte in der Arbeitsmappe A, die den Namen jedes (etwa 20) Arbeitsblatt hat, das ich aus der Arbeitsmappe B (die Hunderte von Arbeitsblättern hat) ziehen möchte. Gibt es eine Möglichkeit, diesen Code zu wiederholen und auf die Spalte in Arbeitsmappe A zu verweisen, um den Blattname in meinem Makro zu ändern, der aus Arbeitsmappe B gezogen wird? Code (Worksheet1 Annahme, daß der Name des Arbeitsblatt I aus Arbeitsmappe B am Zug)

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 

End Function

Answer 1

Edited die folgenden Versuchen.

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