Solved

Macro to pull multiple files from a directory

Posted on 2011-03-21
6
371 Views
Last Modified: 2012-05-11
Question:
Hello

Here's the situation.

I have a directory file that has multiple spreadsheets. Each spreadsheet has 3 worksheets within it.
On the second worksheet title "SST" there is data from columns A-I, and a varying amount of rows.

I need a macro that will extract the data from the SST worksheets of all excel files within the directory, and then populate that into a single worksheet.

attached is some code that doesn't work, but is what I'm working with.

thanks
Brandon


Sub Sample()
    Dim wb As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim i As Long, LastRowWs1 As Long, LastRowWs2 As Long
    Dim foundfile As String, pathoffiles As String
    
    Set ws1 = ActiveWorkbook.Sheets("Sheet1")
    
    '~~> Change path of the directory here
    pathoffiles = "C:\Temp\"
    
    foundfile = Dir(pathoffiles & "*.xls") '<~~~  .xlsx of 2007/2010
    
    Do While Len(foundfile) <> 0
        
        LastRowWs1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
        
        Set wb = Workbooks.Open(pathoffiles & foundfile)
        Set ws2 = wb.Sheets("SST")
        
        LastRowWs2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
        
        ws2.Range("A1:A" & LastRowWs2).Copy ws1.Range("A" & LastRowWs1)
        
        wb.Close savechanges:=False
        
        foundfile = Dir
    Loop

    Set ws2 = Nothing
    Set wb = Nothing
End Sub

Open in new window

0
Comment
Question by:KnutsonBM
  • 3
  • 2
6 Comments
 
LVL 50

Accepted Solution

by:
Dave Brett earned 500 total points
ID: 35186781
I've modified my Article at http://www.experts-exchange.com/A_2804.html to suit

Cheers

Dave
Public Sub ConsolidateSheets()
    Dim Wb1 As Workbook
    Dim Wb2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim rngArea As Range
    Dim lrowSpace As Long
    Dim lSht As Long
    Dim lngCalc As Long
    Dim lngRow As Long
    Dim lngCol As Long
    Dim X()
    Dim bProcessFolder As Boolean
    Dim bNewSheet As Boolean

    Dim StrPrefix
    Dim strFileName As String
    Dim strFolderName As String

    'variant declaration needed for the Shell object to use a default directory
    Dim strDefaultFolder As Variant


    bProcessFolder = (MsgBox("Process a single folder (Yes)," & vbNewLine & "or single file (No)", vbYesNo, "Application Scope: Folder or single File") = vbYes)
    bNewSheet = (MsgBox("Extract all data to a single sheet (TRUE)," & vbNewLine & "or a target file sheet for each source sheet(FALSE)", vbYesNo, "Output Format: Single sheet or sheet by sheet collection") = vbYes)
    If Not bProcessFolder Then
        If Not bNewSheet Then
            MsgBox "There isn't much point creating a exact replica of your source file :)"
            Exit Sub
        End If
    End If

    'set default directory here if needed
    strDefaultFolder = "C:\temp"

    'If the user is collating all the sheets to a single target sheet then the row spacing
    'to distinguish between different sheets can be set here
    lrowSpace = 1

    If bProcessFolder Then
        strFolderName = BrowseForFolder(strDefaultFolder)
        'Look for xls, xlsx, xlsm files
        strFileName = Dir(strFolderName & "\*.xls*")
    Else
        strFileName = Application _
                      .GetOpenFilename("Select file to process (*.xls), *.xls")
    End If

    Set Wb1 = Workbooks.Add(1)
    Set ws1 = Wb1.Sheets(1)
    If Not bNewSheet Then ws1.Range("A1:B1") = Array("workbook name", "worksheet count")

    'Turn off screenupdating, events, alerts and set calculation to manual
    With Application
        .DisplayAlerts = False
        .EnableEvents = False
        .ScreenUpdating = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    'set path outside the loop
    StrPrefix = strFolderName & IIf(bProcessFolder, "\", vbNullString)

    Do While Len(strFileName) > 0
        'Provide progress status to user
        Application.StatusBar = Left("Processing " & strFolderName & "\" & strFileName, 255)
        'Open each workbook in the folder of interest
        Set Wb2 = Workbooks.Open(StrPrefix & strFileName)
        If Not bNewSheet Then
            'add summary details to first sheet
            ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Wb2.Name
            ws1.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = Wb2.Sheets.Count
        End If
        Set ws2 = Wb2.Sheets("SST")
        If bNewSheet Then
            'All data to a single sheet
            'Skip importing target sheet data if the source sheet is blank
            Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious)

            If Not rng2 Is Nothing Then
                Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious)
                'Find the first blank row on the target sheet
                If Not rng1 Is Nothing Then
                    Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A"))
                    'Ensure that the row area in the target sheet won't be exceeded
                    If rng3.Rows.Count + rng1.Row < Rows.Count Then
                        'Copy the data from the used range of each source sheet to the first blank row
                        'of the target sheet, using the starting column address from the source sheet being copied
                        ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)
                    Else
                        MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _
                               "sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name
                        Wb2.Close False
                        Exit Do
                    End If
                    'colour the first of any spacer rows
                    If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen
                Else
                    'target sheet is empty so copy to first row
                    ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
                End If
            End If
        Else
            'new target sheet for each source sheet
            ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count)
            'Remove any links in our target sheet
            With Wb1.Sheets(Wb1.Sheets.Count).Cells
                .Copy
                .PasteSpecial xlPasteValues
            End With
            On Error Resume Next
            Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name
            'sheet name already exists in target workbook
            If Err.Number <> 0 Then
                'Add a number to the sheet name till a unique name is derived
                Do
                    lSht = lSht + 1
                    Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht)
                Loop While Not ws3 Is Nothing
                lSht = 0
            End If
            On Error GoTo 0
        End If

        'Close the opened workbook
        Wb2.Close False
        'Check whether to force a DO loop exit if processing a single file
        If bProcessFolder = False Then Exit Do
        strFileName = Dir
    Loop

    'Remove any links if the user has used a target sheet
    If bNewSheet Then
        With ws1.UsedRange
            .Copy
            .Cells(1).PasteSpecial xlPasteValues
            .Cells(1).Activate
        End With
    Else
        'Format the summary sheet if the user has created separate target sheets
        ws1.Activate
        ws1.Range("A1:B1").Font.Bold = True
        ws1.Columns.AutoFit
    End If

    With Application
        .CutCopyMode = False
        .DisplayAlerts = True
        .EnableEvents = True
        .ScreenUpdating = True
        .Calculation = lngCalc
        .StatusBar = vbNullString
    End With
End Sub


Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'From Ken Puls as used in his vbaexpress.com article
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284

    Dim ShellApp As Object
    'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
                   BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

    'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0

    'Destroy the Shell Application
    Set ShellApp = Nothing

    'Check for invalid or non-entries and send to the Invalid error
    'handler if found
    'Valid selections can begin L: (where L is a letter) or
    '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select

    Exit Function

Invalid:
    'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
End Function

Open in new window

0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35187159
Brandon the code that I gave you above was for another question :)

You will have to slightly amend it for this question.

1) Could you confirm the path where the files are kept.
2) Which office version are you using?
3) Is the data in Col A or in other columns as well?

Dave: I see that you have already replied and I am not ignoring your post :)

Sid
0
 
LVL 6

Author Closing Comment

by:KnutsonBM
ID: 35191825
awsome. amazing. fabulous.
0
Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35191840
KnutsonBM: I will pretend that you missed my post in error :D

Sid
0
 
LVL 50

Expert Comment

by:Dave Brett
ID: 35194503
Thanks KnutsonBM :)


>KnutsonBM: I will pretend that you missed my post in error :D
Sid, but you hadn't actually proferred a solution - you'd asked for more information

Cheers

Dave
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35195839
>>>Sid, but you hadn't actually proferred a solution - you'd asked for more information

Absolutely! which was missed by the author by mistake ;)

Sid
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

In this article, I will show you HOW TO: Suppress Configuration Issues and Warnings Alert displayed in Summary status for ESXi 6.5 after enabling SSH or ESXi Shell.
For cloud, the “train has left the station” and in the Microsoft ERP & CRM world, that means the next generation of enterprise software from Microsoft is here: Dynamics 365 is Microsoft’s new integrated business solution that unifies CRM and ERP fun…
Viewers will learn the different options available in the Backstage view in Excel 2013.
Viewers will learn what comprises a theme in Excel 2013, as well as how to customize them.

760 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now