How can I activate the same worksheet on multiple workbooks after Application.GetOpenFilename?-CodePudding

I am trying to extract info from multiple workbooks using the script below. The problem is that the information I need to extract is in one specific worksheet. I can't activate that worksheet when using Workbooks.Open FileNames(i).

Can someone knows how to solve?

Sub Extract()
Dim FileNames As Variant
Dim i As Integer
Application.ScreenUpdating = False
Range("C2").Select
FileNames = Application.GetOpenFilename(FileFilter:="Excel Filter (*.xlsx), *.xlsx", Title:="Open File(s)", MultiSelect:=True)

For i = 1 To UBound(FileNames)
    Workbooks.Open FileNames(i)
    ActiveWorkbook.Sheets("7b").Range("B2:H8").Select
    Selection.Copy
    Windows("All.xlsm").Activate
    Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
    Workbooks.Open FileNames(i)
    ActiveWorkbook.Close SaveChanges:=False
    ActiveCell.Offset(1, 0).Activate

Next i

End Sub

Thank you!!!

CodePudding user response：

If you open it with only Workbooks.Open, you have no handle to the newly opened book. If you instead do like this:

Dim wb As Workbook
Set wb = Workbooks.Open(FileNames(i))
wb.Worksheets("Your sheet name").Activate

you can use the variable to control your specific workbook.

CodePudding user response：

Copy From Multiple Workbooks

Sub ExtractData()
    
    Const sName As String = "7b"
    Const srgAddress As String = "B2:H8"
    
    Const dName As String = "Sheet1" ' adjust!!!
    Const dFirstCellAddress As String = "C2"
    
    Dim FilePaths As Variant: FilePaths = Application.GetOpenFilename( _
        FileFilter:="Excel Filter (*.xlsx), *.xlsx", _
        Title:="Open File(s)", _
        MultiSelect:=True)
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    ' If the code is not in the All.xlsm workbook, then use
    'Dim dwb As Workbook: Set dwb = Workbooks("All.xlsm")
    Dim dws As Worksheet: Set dws = dwb.Worksheets(dName)
    Dim drCount As Long: drCount = dws.Range(srgAddress).Columns.Count
    Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim srg As Range
    Dim i As Long
    
    For i = 1 To UBound(FilePaths)
        Set swb = Workbooks.Open(FilePaths(i))
        On Error Resume Next
            Set sws = swb.Worksheets(sName)
        On Error GoTo 0
        If Not sws Is Nothing Then
            Set srg = sws.Range(srgAddress)
            srg.Copy
            dfCell.PasteSpecial Paste:=xlPasteAll, Transpose:=True
            Set dfCell = dfCell.Offset(drCount)
            Debug.Print dfCell.Address
            Set sws = Nothing
        End If
        swb.Close SaveChanges:=False
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox "Data extracted.", vbInformation

End Sub