CODEWITHSUNDEEP
vbaexcelfiltering
watakushi
watakushi

Reputation: 51

VBA Clear filters before merging files

I'm working on a spreadsheet automation process through VBA and had success so far, but I'm kinda stuck on a single element of it, namely clearing filters before copying. This code is located in a module on a masterfile, and what it does is open every workbook in a folder (each file has a single sheet), copy all data from A2 to AJ(however many rows there are), paste it on the masterfile, then close the file and move to the next one in the folder, until all files have been merged into the master, one block of data directly below the previous one. It works perfectly. The issue is that in some cases, these files might have filtered columns, and everything that is filtered out will not be copied over. These files are sent from another department. I did search SO and found different ways to clear filters, I even tried a code that worked on its own, but I just can't make them work on my code for some reason, maybe I'm placing them in a wrong spot or something? Also, is there anything that I should change to clean/optimize the code?

Thanks for your time and attention!

Option Explicit

Sub ExcelMerge()
    Dim wbkReports As Workbook
    Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set mergeObj = CreateObject("Scripting.FileSystemObject")

    Set dirObj = mergeObj.Getfolder("C:\Users\Report")
    Set filesObj = dirObj.Files
For Each everyObj In filesObj
    Set wbkReports = Workbooks.Open(everyObj)

    Range("A2:AJ" & Range("A65536").End(xlUp).Row).Copy

    ThisWorkbook.Worksheets(1).Activate
    Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
    Application.CutCopyMode = False
    wbkReports.Close
Next

    AddFormulas

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub AddFormulas()
    Dim lastRow As Long, i As Long
    Dim ws As Worksheet

    Set ws = Sheets("Report")

    lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row

With ws
    For i = 10 To lastRow
        If Len(Trim(.Range("A" & i).Value)) <> 0 Then _
        .Range("AK" & i).FormulaR1C1 = "formula here"
        .Range("AL" & i).FormulaR1C1 = "formula here"
        .Range("AM" & i).FormulaR1C1 = "formula here"
    Next i
End With
End Sub

Upvotes: 0

Views: 168

Answers (1)

Tom
Tom

Reputation: 9888

Have a look at this. Also you should define which sheet you're using instead of just copying from Range("A2:AJ... as this could lead to errors with copying data from the wrong sheet. Also if you add SaveChanges:=False when you close the workbook down you'll prevent from making the unfiltering of ranges permanent

Sub ExcelMerge()
    Dim wbkReports As Workbook
    Dim ws As Worksheet
    Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set mergeObj = CreateObject("Scripting.FileSystemObject")

    Set dirObj = mergeObj.Getfolder("C:\Users\Report")
    Set filesObj = dirObj.Files
    For Each everyObj In filesObj
        Set wbkReports = Workbooks.Open(everyObj)

        For Each ws In wbkReports.Worksheets
            If ws.AutoFilterMode Then ws.AutoFilter.ShowAllData
        Next ws

        Range("A2:AJ" & Range("A65536").End(xlUp).Row).Copy
        ThisWorkbook.Worksheets(1).Activate
        Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
        Application.CutCopyMode = False
        ' Include savechanges:=False to not save the unfiltering of sheets
        wbkReports.Close savechanges:=False
    Next

    AddFormulas

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Upvotes: 1

Related Questions