Excel VBA- Importation de feuilles spécifiques dans un classeur à partir d'un classeur externe

Question

J'ai été en mesure de tirer parti du code de quelqu'un d'autre pour importer une feuille de calcul à partir d'un classeur externe, mais le code me demande de modifier manuellement le nom de la feuille de calcul.

J'ai actuellement une colonne dans le classeur A qui a le nom de chaque feuille de travail (environ 20) que j'essaie de tirer du classeur B (qui a des centaines de feuilles de calcul). Est-il un moyen de boucler ce code et de référencer la colonne dans le classeur A pour modifier le nom de feuille dans ma macro pour être extrait du classeur B? code ci-dessous (en supposant Worksheet1 est le nom de la feuille de calcul je tire du classeur B)

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

Edité Essayez ce qui suit.

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