Excel masterfile vba

[moshc]

Good day!

Anyone can help me please?

I've been looking for an EXCEL VBA code in which i will have the option to select a folder path first which all the workbooks i need to combined is saved and have all the first sheets in all workbook in that specific folder is then combined to a new workbook.

Would really much appreciate any immediate response.

Thank you!

 

[jskasango]

This worked for me:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim fso, oFolder, oSubfolder, oFile, queue As Collection, MyFolder As String
    Dim wsDest As Worksheet, wkbSource As Workbook, lCol As Long, lRow As Long
    Dim splt As Variant, FN As String, wbName As String, x As Long: x = 1
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set queue = New Collection
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .Show
        .AllowMultiSelect = False
        If .SelectedItems.Count = 0 Then
            MsgBox "You did not select a folder."
            Exit Sub
        End If
        MyFolder = .SelectedItems(1) & "\"
    End With
    queue.Add fso.GetFolder(MyFolder)
    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder
        Next oSubfolder
        For Each oFile In oFolder.Files
            'If Right(oFile, 3) Like "xl*" Then
            If Right(oFile, 3) Like "ls*" Then
                Set wkbSource = Workbooks.Open(oFile)
                splt = Split(oFile, "\")
                FN = splt(UBound(splt) - 1)
                wbName = Split(wkbSource.Name, ".")(0)
                If Not IsError(Evaluate("=ISREF('[" & oFile.Name & "]" & "StockList" & "'!$A$1)")) Then
                    If Sheets("StockList").Range("A25") <> "" Then
                        With Sheets("StockList")
                            If x = 1 Then
                                lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
                                wsDest.Range("A1") = "NurseryName"
                                .Range("A1").Resize(, lCol).Copy
                                wsDest.Range("B1").PasteSpecial xlPasteValues
                                x = x + 1
                                lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                                .Range("A25").Resize(lRow - 24, lCol).Copy
                                wsDest.Range("B2").PasteSpecial xlPasteValues
                                wsDest.Range("A2").Resize(lRow - 24) = FN & "-" & wbName
                            Else
                                lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                                lCol = .Cells(25, Columns.Count).End(xlToLeft).Column
                                .Range("A25").Resize(lRow - 24, lCol).Copy
                                wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
                                wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lRow - 24) = FN & "-" & wbName
                            End If
                        End With
                    End If
                End If
                Application.DisplayAlerts = False
                wkbSource.Close False
                Application.DisplayAlerts = True
            End If
        Next oFile
    Loop
    '=================================
    wsDest.Name = "2019A" & "-StockList"
   ' ActiveWorkbook.SaveAs FileName:=MyFolder & FN & "-" & "EntryLists", FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:="2019A" & "-" & "EntryLists", FileFormat:=xlCSV, CreateBackup:=False
  
    Rows("1:1").Select
    Selection.AutoFilter
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    Application.ScreenUpdating = True
    Application.ScreenUpdating = True
    '=================================
End Sub

@mumps mine refused to work until I fumbled with these two lines of code:-
If Right(oFile, 3) Like "ls*" Then (I had to change the 3 and replace it with a 2 otherwise it was returning nothing at all)
wsDest.Range("A2").Resize(lRow - 24) = FN & "-" & wbName ( When running for Stocklist I replaced 24 with 26 and everything aligns correctly! is there a smarter way of addressing this?)
At least now I can work although I still have to manually move the output file into the parent folder manually through windows explorer. But I can testify that this is saving me light years! Thanks a lot for your help! - Kasango.

 

[jskasango]

This worked for me:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim fso, oFolder, oSubfolder, oFile, queue As Collection, MyFolder As String
    Dim wsDest As Worksheet, wkbSource As Workbook, lCol As Long, lRow As Long
    Dim splt As Variant, FN As String, wbName As String, x As Long: x = 1
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set queue = New Collection
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .Show
        .AllowMultiSelect = False
        If .SelectedItems.Count = 0 Then
            MsgBox "You did not select a folder."
            Exit Sub
        End If
        MyFolder = .SelectedItems(1) & "\"
    End With
    queue.Add fso.GetFolder(MyFolder)
    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder
        Next oSubfolder
        For Each oFile In oFolder.Files
            'If Right(oFile, 3) Like "xl*" Then
            If Right(oFile, 3) Like "ls*" Then
                Set wkbSource = Workbooks.Open(oFile)
                splt = Split(oFile, "\")
                FN = splt(UBound(splt) - 1)
                wbName = Split(wkbSource.Name, ".")(0)
                If Not IsError(Evaluate("=ISREF('[" & oFile.Name & "]" & "StockList" & "'!$A$1)")) Then
                    If Sheets("StockList").Range("A25") <> "" Then
                        With Sheets("StockList")
                            If x = 1 Then
                                lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
                                wsDest.Range("A1") = "NurseryName"
                                .Range("A1").Resize(, lCol).Copy
                                wsDest.Range("B1").PasteSpecial xlPasteValues
                                x = x + 1
                                lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                                .Range("A25").Resize(lRow - 24, lCol).Copy
                                wsDest.Range("B2").PasteSpecial xlPasteValues
                                wsDest.Range("A2").Resize(lRow - 24) = FN & "-" & wbName
                            Else
                                lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                                lCol = .Cells(25, Columns.Count).End(xlToLeft).Column
                                .Range("A25").Resize(lRow - 24, lCol).Copy
                                wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlPasteValues
                                wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lRow - 24) = FN & "-" & wbName
                            End If
                        End With
                    End If
                End If
                Application.DisplayAlerts = False
                wkbSource.Close False
                Application.DisplayAlerts = True
            End If
        Next oFile
    Loop
    '=================================
    wsDest.Name = "2019A" & "-StockList"
   ' ActiveWorkbook.SaveAs FileName:=MyFolder & FN & "-" & "EntryLists", FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:="2019A" & "-" & "EntryLists", FileFormat:=xlCSV, CreateBackup:=False
  
    Rows("1:1").Select
    Selection.AutoFilter
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    Application.ScreenUpdating = True
    Application.ScreenUpdating = True
    '=================================
End Sub

DONE! reverted to your above code. All is well. Saving as values and no overshooting of A2. Code was not seeing files until I edited the line:-
If Right(oFile, 3) Like "ls*" Then by replacing 3 with a 2. Now I wish it could be saving inside the parent folder (MyFolder). Once again and forever, THANK YOU!- Kasango

 

[mumps]

You are very welcome. In order to save in the parent folder, you have to use the variable 'MyFolder' as in this line of code:

ActiveWorkbook.SaveAs FileName:=MyFolder & FN & "-" & "EntryLists", FileFormat:=xlCSV, CreateBackup:=False