crepe
asked on
Extract data from multiple worksheets in a workbook?
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!!
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
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER