Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

Extract data from multiple worksheets in a workbook?

Posted on 2013-05-23
2
Medium Priority
?
243 Views
Last Modified: 2013-05-28
Good morning,

I want to add data from another sheet to this summary macro.
Right now, it only looks at Worksheet "Finance" but I want to add 2 new Worksheets, "Company" and "Buyer" to the Summary too.

I want the macro to add "Company" worksheet Cell "A2" and "G2" and "Buyer" worksheet Cell "B2" and "F2".

Thank you!!



Option Explicit

Sub Master()
    
    Dim StartPath As String
    Dim Results() As Variant
    
    StartPath = GetDirectory2
    
    If StartPath <> "" Then
        Application.ScreenUpdating = False
        ReDim Results(0) As Variant
        DoTheWork Results, StartPath
        Workbooks.Add
        Range("a1:b" & UBound(Results, 2)).Value = Application.Transpose(Results)
        Columns.AutoFit
        Application.ScreenUpdating = True
        MsgBox "Done"
    End If
    
End Sub

Private Sub DoTheWork(ByRef Results As Variant, FldPath As String)
    
    Dim fso As Object, fld As Object, fil As Object, sf As Object
    Dim WbWasOpen As Boolean
    Dim wb As Workbook, ws As Worksheet
    Dim GetValue As Variant
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(FldPath)
    
    On Error Resume Next

    For Each fil In fld.Files
        If LCase(fil.Name) Like "*verification*.xls*" Then
            Set wb = Workbooks(fil.Name)
            If Err <> 0 Then
                WbWasOpen = False
                Set wb = Workbooks.Open(fil.Path)
                Err.Clear
            Else
                WbWasOpen = True
            End If
            Set ws = wb.Worksheets("Finances")
            If Err = 0 Then
                GetValue = ws.Range("f12").Value
                If Not WbWasOpen Then wb.Close False
                If LBound(Results, 1) > 0 Then
                    ReDim Preserve Results(1 To 2, 1 To UBound(Results, 2) + 1) As Variant
                Else
                    ReDim Results(1 To 2, 1 To 2) As Variant
                    Results(1, 1) = "File"
                    Results(2, 1) = "Value"
                End If
                Results(1, UBound(Results, 2)) = fil.Path
                Results(2, UBound(Results, 2)) = GetValue
            Else
                Err.Clear
            End If
        End If
    Next
    
    On Error GoTo 0

    For Each sf In fld.SubFolders
        DoTheWork Results, sf.Path
    Next
    
End Sub

Private Function GetDirectory2(Optional Msg As String = "Select Folder:") As String
    
    ' Use this version when you want to be able to create a new directory and
    ' have the function return that path
    
    Dim objShell As Object 'Shell32.Shell
    Dim objFolder As Object 'Shell32.Folder
    Dim objFolderItem As Object 'Shell32.FolderItem
    
    GetDirectory2 = ""
    
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, Msg, 0, 0)
    
    If (Not objFolder Is Nothing) Then
        Set objFolderItem = objFolder.Self
        If (Not objFolderItem Is Nothing) Then
            GetDirectory2 = objFolderItem.Path
        End If
    End If
    
    Set objFolderItem = Nothing
    Set objFolder = Nothing
    Set objShell = Nothing
    
End Function

Open in new window

0
Comment
Question by:crepe
2 Comments
 
LVL 32

Accepted Solution

by:
Robberbaron (robr) earned 1500 total points
ID: 39196054
can you post a sampleworkbook as that is different to what the current macro does.

do you want just the 2 values from the workkbook ?
you could try using the macro recorder while copying data manually and post the results of that for us to review.  its a very good starting point.
0
 

Author Closing Comment

by:crepe
ID: 39203267
I figured it out on my own. Thank you!
0

Featured Post

[Webinar] Cloud and Mobile-First Strategy

Maybe you’ve fully adopted the cloud since the beginning. Or maybe you started with on-prem resources but are pursuing a “cloud and mobile first” strategy. Getting to that end state has its challenges. Discover how to build out a 100% cloud and mobile IT strategy in this webinar.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

876 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