Macro to Search in Multiple Folders / Open / Copy&Paste all info into single workbook

[brumby]

Hiya all!!!

I suspect this is a challenge, even for the highest of highest excel / VBA gurus, however worth a try!!! I will try to explain.

I want to create a workbook in the following location ( work network folder )

K:\Materials to keep\Stores\Trial and Service Kit Builds\ALL CURRENT KIT STATUS\RETRIEVE_LIVE_KIT_DATA.xlsm

within that workbook, I want the user to be able to click an object / button which will start off a macro and to the following :-

1. Goto the following location K:\Materials to keep\Stores\Trial and Service Kit Builds\ALL CURRENT KIT STATUS\2. KITS IN PROGRESS and in there, open each excel file and copy the contents of the "Pick List" worksheet columns A:AH and copy them into the RETRIEVE_LIVE_KIT_DATA.xlsm workbook, sheet called "ALL KITS"

2. Goto the following location K:\Materials to keep\Stores\Trial and Service Kit Builds\ALL CURRENT KIT STATUS\3. KITS COMPLETE AWAITING COLLECTION and in there, open each excel file and copy the contents of the "Pick List" worksheet columns A:AH and copy them into the RETRIEVE_LIVE_KIT_DATA.xlsm workbook, sheet called "ALL KITS" taking into account the section above

3. Goto the following location K:\Materials to keep\Stores\Trial and Service Kit Builds\ALL CURRENT KIT STATUS\4. KITS LINE SIDE and in there, open each excel file and copy the contents of the "Pick List" worksheet columns A:AH and copy them into the RETRIEVE_LIVE_KIT_DATA.xlsm workbook, sheet called "ALL KITS" taking into account the section above

4. Goto the following location K:\Materials to keep\Stores\Trial and Service Kit Builds\ALL CURRENT KIT STATUS\5. KITS TO BE SCANNED BACK TO STORES and in there, open each excel file and copy the contents of the "Pick List" worksheet columns A:AH and copy them into the RETRIEVE_LIVE_KIT_DATA.xlsm workbook, sheet called "ALL KITS" taking into account the section above

Close and save the workbook in K:\Materials to keep\Stores\Trial and Service Kit Builds\ALL CURRENT KIT STATUS\RETRIEVE_LIVE_KIT_DATA.xlsm

I need to capture all xlsx files in those folders and copy their contents. I know it sounds easy, but I doubt this is possible!!

Appreciate your help and feedback xx

 

[bsquad]

It wasn't really to clear whether the order of workbooks mattered;

When you are in the visual basic editor in 'ThisWorkbook' paste

-this will take care of your 'button' to initiate the process >>but instead of a button, its a SubMenu - Right Click. In order for this to load for the FIRST time after you have pasted you can manually run the sub when you are in the editor or save the workbook, close it, and reopen

Private Sub Workbook_Open()    
    Call SubMenu
End Sub
 Private Sub Workbook_Close()
    Call DeleteSubmenu
End Sub

in a Module paste

 Sub SubMenu()
    Dim Bar As CommandBar
    Dim NewMenu As CommandBarControl
    Dim NewSubmenu As CommandBarButton
    DeleteSubmenu
    Set Bar = CommandBars("Cell")
    Set NewMenu = Bar.Controls.Add(Type:=msoControlPopup, before:=1, temporary:=True)
    NewMenu.Caption = "&Function"
    Bar.Controls(2).BeginGroup = True
    Set NewSubmenu = NewMenu.Controls.Add(Type:=msoControlButton)
    With NewSubmenu
        .FaceId = 266
        .Caption = "Aggregate"
        .OnAction = "Aggregation"
    End With
End Sub
Sub DeleteSubmenu()
    On Error Resume Next
    CommandBars("Cell").Controls("&Function").Delete
End Sub


Sub Aggregation()    
    Dim SourceSheet As Worksheet
    Dim OpenSourceWorkbook As Variant
    Dim SourceWorkbook As Workbook
    Dim i As Integer


        OpenSourceWorkbook = Application.GetOpenFilename(filefilter:="Excel Workbooks (*.xlsx; *xlsm,*.xlsx;*xlsm", _
                            Title:="Source File Select", MultiSelect:=True)
                            On Error GoTo ExitSub
        Set SourceWorkbook = Workbooks.Open(OpenSourceWorkbook(1))
        Application.ScreenUpdating = False
            For i = LBound(OpenSourceWorkbook) To UBound(OpenSourceWorkbook)
            Set SourceWorkbook = Workbooks.Open(Filename:=OpenSourceWorkbook(i), ReadOnly:=True)
                For Each SourceSheet In SourceWorkbook.Sheets
                    Dim ER As Long
                    ER = SourceSheet.Range("A" & Rows.Count).End(xlUp).Row
                    If SourceSheet.Name = "Pick List" Then
                        SourceSheet.Range("A1:AH" & ER).Copy
                    End If
                        If ThisWorkbook.Worksheets("ALL KITS").Range("A1").Value = "" Then
                            ThisWorkbook.Worksheets("ALL KITS").Range("A1").PasteSpecial Paste:=xlPasteAll
                        Else
                        On Error Resume Next
                            ThisWorkbook.Worksheets("ALL KITS").Range("A1").End(xlDown).Offset(1).PasteSpecial Paste:=xlPasteAll
                        End If
                        Application.CutCopyMode = False
                Next SourceSheet
                SourceWorkbook.Close savechanges:=False
            Next i
ExitSub:
Exit Sub
End Sub