In need of Tweak to old Code

bradjedis
4StarLounger
Posts: 433
Joined: 30 Mar 2010, 18:49
Location: United States

In need of Tweak to old Code

Post by bradjedis »

Greetings, I have the below code that works well enough, however I would like to limit it to import only one specific Sheet from each of the files it is querying. The files this imports has multiple sheets in each workbook. I would like to limit to a sheet Named "PBR". each workbook will have a sheet named that.

Code: Select all

Sub InportSheets()

Dim directory As String, fileName As String, sheet As Worksheet, total As Integer

Application.ScreenUpdating = False
Application.DisplayAlerts = False

directory = "C:\Users\xxx\Downloads\__PBRs for Test Load\"
fileName = Dir(directory & "*.xl??")

Do While fileName <> ""
    Workbooks.Open (directory & fileName)
        
    For Each sheet In Workbooks(fileName).Worksheets
        total = Workbooks("import-sheets.xlsm").Worksheets.Count
        Workbooks(fileName).Worksheets(sheet.Name).Copy _
        after:=Workbooks("import-sheets.xlsm").Worksheets(total)
    Next sheet
        
    Workbooks(fileName).Close
    fileName = Dir()
Loop

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

User avatar
HansV
Administrator
Posts: 71177
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: In need of Tweak to old Code

Post by HansV »

Here you go:

Code: Select all

Sub ImportPBR()
    Dim directory As String
    Dim fileName As String
    Dim wbkS As Workbook
    Dim wbkT As Workbook
    Dim sheet As Worksheet
    Dim total As Integer

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set wbkT = Workbooks("import-sheets.xlsm")

    directory = "C:\Users\xxx\Downloads\__PBRs for Test Load\"
    fileName = Dir(directory & "*.xl??")

    Do While fileName <> ""
        Set wbkS = Workbooks.Open(directory & fileName)
        Set sheet = wbkS.Worksheets("PBR")
        total = wbkT.Worksheets.Count
        sheet.Copy After:=wbkT.Worksheets(total)
        wbkS.Close SaveChanges:=False
        fileName = Dir
    Loop

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Regards,
Hans

bradjedis
4StarLounger
Posts: 433
Joined: 30 Mar 2010, 18:49
Location: United States

Re: In need of Tweak to old Code

Post by bradjedis »

Sorry for delay in replying... This works great!

Many thanks!