0

I need some help (may be a lot of help) to write a macro which will do the following -

In the master workbook user will Select option -> A, B or C from drop down in sheet1 and click on the run macro button. The macro would do the following -

->select sheet100 in master workbook

-> select files to open (all available in single folder, arranged by name)

-> Loop starts

-> open target file (has to start from 1st file by name in the folder)

-> search target file first row for value "Dimension"

 -> If Option A was selected set auto filter on Dimension with filters "One" and "two"
 -> If Option B was selected set auto filter on Dimension with filters "three" and " and "four"
 -> If Option C was selected set auto filter on Dimension with filters "five" and " and "six"

-> copy all filtered data

-> paste special values starting from cell A6 of sheet100 (which was activated above before loop started) in master workbook

-> goes to next sheet of master file

-> If there is a second worksheet, go to that worksheet

->  use the same logic to filter and copy data to master workbook's next sheet
    
-> loops till the last worksheet in the last target workbook

I have the code in bits and pieces, like getting the value selected in the drop down into a string, activating sheet100, opening the files in the folder and running the loop for all selected target files, but am unable to complete the whole code.

Any help on this will be much appreciated.

braX
  • 11,506
  • 5
  • 20
  • 33
Shanturoy
  • 3
  • 3

2 Answers2

0

When copying filtered lists use SpecialCells(xlCellTypeVisible). I have copied the header with the filtered range to the target sheet and then deleted the header. This avoids the complication of dealing with an empty list.

Update - Removed automatic sheet creation and added check that there is a sheet to put data on. Copies all data (with header) not just filter column.

Update 2 - Using Sheet100 to Sheet118 as sheet code names.

Update 3 - Apply filter to all columns, pastespecial values only. There are things you can do to that might speed up the code see here

Option Explicit

Sub Macro1()

    Const FIRST_SHEET = 100
    Const LAST_SHEET = 118
    Const TARGET_ROWNO = 1 '
    Const TARGET_COLNO = 7 ' G
    Const FILTER_COL = "Vertical"

    Dim wbData As Workbook, wbMaster As Workbook
    Dim ws As Worksheet, wsData As Worksheet, wsMaster As Worksheet
    Dim sFolder As String, sFile As String, sOption As String
    Dim rng As Variant, colno As Integer, iLastRow As Long, iLastCol As Integer
    Dim crit As Variant, n As Long
    Dim OFLastCol As Long, OFLastRow As Long

    Dim dict As Object, sCodeName As String
    Set dict = CreateObject("Scripting.Dictionary")

    sOption = Sheet52.Range("H8").Value 'capturing selected vertical

    Select Case UCase(sOption) 'setting the filter values
        Case "INSURANCE": crit = Array("INSURANCE")
        Case "BFS": crit = Array("BFS")
        Case "PNR": crit = Array("RETAIL", "MLEU", "T&H")
        Case "FSI GGM": crit = Array("INSURANCE", "BFS")
        Case Else
            MsgBox "No option selected", vbCritical
            Exit Sub
    End Select

    ' select folder
    Application.StatusBar = "Please be select folder to scan..."
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = sFolder
        .Show
        sFolder = .SelectedItems(1)
    End With
    sFile = Dir(sFolder & "\*.xls*")

    Set wbMaster = ThisWorkbook

    ' clear data sheets
    ' and map code names to index
    For Each ws In wbMaster.Sheets
        sCodeName = ws.CodeName 'Sheet100 to sheet118
        dict(sCodeName) = ws.Index ' codename to index

        ' clear old data
        n = Mid(sCodeName, 6)
        If n >= FIRST_SHEET And n <= LAST_SHEET Then

           Set rng = ws.UsedRange
           iLastCol = rng.Column + rng.Columns.Count - 1
           iLastRow = rng.Row + rng.Rows.Count - 1
           If iLastCol >= TARGET_COLNO Then
               Set rng = ws.Range(ws.Cells(TARGET_ROWNO, TARGET_COLNO), ws.Cells(iLastRow, iLastCol))
               rng.Cells.ClearContents
               'Debug.Print "Cleared", n, rng.Address
           End If

        End If
    Next

    ' scan files
    n = 100
    Do While Len(sFile) > 0
        Set wbData = Workbooks.Open(sFolder & "\" & sFile, ReadOnly:=True) ' updatelink, readonly

        ' open each sheet in turn
        For Each wsData In wbData.Sheets

            ' find the filter column in row 1
            Set rng = wsData.Rows(1).Find(FILTER_COL, LookIn:=xlValues, LookAt:=xlWhole)
            If Not rng Is Nothing Then

                colno = rng.Column
                ' last row of filter column
                OFLastRow = wsData.Cells(Rows.Count, colno).End(xlUp).Row

                If OFLastRow > 1 Then
                    ' range to apply filter to
                    OFLastCol = wsData.Cells(1, Columns.Count).End(xlToLeft).Column ' move left
                    
                    Set rng = wsData.Range("A1", wsData.Cells(OFLastRow, OFLastCol))
                    rng.AutoFilter Field:=colno, Criteria1:=crit, Operator:=xlFilterValues
                    ' range to copy
                    Set rng = rng.SpecialCells(xlCellTypeVisible)

                     ' is there data to copy
                    If rng.Rows.Count > 1 Or rng.Areas.Count > 1 Then

                        ' check sheet available
                        sCodeName = "Sheet" & n
                        If dict.exists(sCodeName) Then
                            Set wsMaster = wbMaster.Sheets(dict(sCodeName))
                        Else
                            MsgBox sCodeName & " not found", vbCritical
                            Exit Sub
                        End If

                        ' copy / paste all columns of visible rows
                        rng.Copy
                        With wsMaster.Cells(TARGET_ROWNO, TARGET_COLNO)
                            .PasteSpecial Paste:=xlPasteValues
                        End With
                        Application.CutCopyMode = False
                        wsMaster.Activate
                        wsMaster.Range("A1").Select
                    Else
                        MsgBox "No data after filter on sheet " & wsData.Name, vbExclamation, wbData.Name
                    End If
                Else
                   MsgBox "No data in column " & colno & " on sheet " & wsData.Name, vbExclamation, wbData.Name
                End If
            Else
                MsgBox FILTER_COL & " not found on sheet " & wsData.Name, vbExclamation, wbData.Name
            End If
            n = n + 1 ' next data sheet
        Next
        wbData.Close False
        sFile = Dir() ' next file in folder
    Loop

    MsgBox sFolder & " files scanned for option " & sOption, vbInformation
End Sub
CDP1802
  • 13,871
  • 2
  • 7
  • 17
  • @shan I am not braX . Does it work how you wanted ? – CDP1802 Mar 14 '21 at 20:54
  • Hi @CDP1802, thank you for helping me out. I have a couple of clarifications and doubts, please bear with me. The master sheet has 51 worksheets, out of which 19 are used to gather the data. I have named them sheet950 - sheet968, and have placed them serially at the end.To modify the "Scripting.Dictionary" I have done the following - Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") Set wb = ThisWorkbook Set ws = wb.Sheet150 For ws = wb.Sheet150 To Worksheets.Count - 2 'Start of the VBA loop dict.Add ws.Name, 1 Next does this look ok? – Shanturoy Mar 14 '21 at 21:00
  • Sorry, am very new to the forum, and am not sure of the etiquettes here. Can I post by clicking "Answer Your question" as my rambling is a bit long? Oops, just realized that I deleted 1st comment by mistake. Too excited to do things normally! – Shanturoy Mar 14 '21 at 21:01
  • @shan You shouldn't have to change dict. It configure itself with the names of all existing sheets. It is only used when creating addition sheets for the copied data. I assumed the next master sheet would be Sheet101 so before creating it I check if it is existing. – CDP1802 Mar 14 '21 at 21:14
  • @shan So you have existing sheets Sheet100 to Sheet118. Will you never have more than 19 sheets of data ? The data is copied to G1 Is it just data in the Dimension column that gets copied. ? If so why clear all columns the right of G – CDP1802 Mar 14 '21 at 23:04
  • No, there would be these 19 sheets. If the number of source file increases or decreases, I will have to change the worksheets in the master workbook accordingly. The copy will be the entire filtered source data (not just 1 column), the paste will happen starting from G1. Clearing the cells for reuse, in case there is old data in the sheet, as the file will be updated month on month. I ran the macro in debugging mode after commenting out the create sheet part, it goes through without throwing up any error, but did not import the data. – Shanturoy Mar 15 '21 at 06:31
  • @shan Which columns on the scanned sheets have data in them , are they the same on every sheet or does it vary from sheet to sheet. ? – CDP1802 Mar 15 '21 at 11:08
  • figured out where the issues are. As I had put in the line "On Error Resume next", it was not showing any error. After commenting it out, I got "subscript out of range" error due to the (Code name) field (Sheet100) and the "name" being different, and the code "Set wsMaster = wbMaster.Sheets("Sheet" & n) is looking for the Tab name instead of the code name. I tried "Set wsMaster = wbMaster.Sheets("Sheet" & n)" and "Set wsMaster = wbMaster.Worksheets("Sheet" & n)" but am getting the same error. What is the correct syntax for referring to the (name) for the sheet? – Shanturoy Mar 15 '21 at 21:36
  • @shan It is more complicated using codenames but I have a solution. Do you want the datasheets cleared only if there is data to be copied.? That is how it is at the moment, or do you want all the datasheets cleared at the start so that what you see on the sheets at the end is just the new data ? – CDP1802 Mar 16 '21 at 15:07
  • It should clears all the data once the macro is run. I tried to use without the codename, by activating sheet100 before the loop starts, and then Set wsMaster = wbMaster.ActiveSheet and then increment wsMaster by Set wsMaster = wsMaster.Next but this is somehow freezing the macro while running without throwing any error. Maybe going into an infinite loop? I have updated the code I tried in the previous post. – Shanturoy Mar 17 '21 at 05:19
  • The above code worked without error, but for some of the data sheets, it is not filtering on the "Vertical" column, but the 1st available column, hence ending up with no data. Also, even if there is no data, can it move to the next sheet after clearing the available data in the target ? Feel that we are very close to the final code. – Shanturoy Mar 17 '21 at 11:14
  • once again, thanks a ton for all the help. – Shanturoy Mar 18 '21 at 17:19
0

@CDP1802: Update 2 - The code with modifications I made as the filter was failing at the first sheet itself. Instead of selecting 1 column, I selected the full range and used the colno variable to do the filtering.

This worked for fully but took a huge amount of time (nearly 10 minutes) to paste 8200 rows of data with 90 cols for the 1st sheet (overall took 1 hour). I also added Paste:=xlPasteValues argument to be doubly sure but it is still taking a long time. It goes through at a better speed for the sheets having lower amount of data. Any idea why this could be happening?

Also, can you change the filter logic in your code? I will mark that as the accepted answer.

Sub test()
    Const FIRST_SHEET = 100
    Const LAST_SHEET = 118
    Const TARGET_ROWNO = 1 '
    Const TARGET_COLNO = 7 ' G
    Const FILTER_COL = "Vertical"
    Dim OFLastCol As Long
    Dim OFLastRow As Long
    

    Dim wbData As Workbook, wbMaster As Workbook
    Dim ws As Worksheet, wsData As Worksheet, wsMaster As Worksheet
    Dim sFolder As String, sFile As String, sOption As String
    Dim rng As Variant, colno As Integer, iLastRow As Long, iLastCol As Integer
    Dim crit As Variant, n As Long

    Dim dict As Object, sCodeName As String
    Set dict = CreateObject("Scripting.Dictionary")

    sOption = Sheet52.Range("H8").Value 'capturing selected vertical

    Select Case UCase(sOption) 'setting the filter values
        Case "INSURANCE": crit = Array("INSURANCE")
        Case "BFS": crit = Array("BFS")
        Case "PNR": crit = Array("RETAIL", "MLEU", "T&H")
        Case "FSI GGM": crit = Array("INSURANCE", "BFS")
        Case Else
            MsgBox "No option selected", vbCritical
            Exit Sub
    End Select

    ' select folder
    Application.StatusBar = "Please be select folder to scan..."
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = sFolder
        .Show
        sFolder = .SelectedItems(1)
    End With
    sFile = Dir(sFolder & "\*.xls*")

    Set wbMaster = ThisWorkbook

    ' clear data sheets
    ' and map code names to index
    For Each ws In wbMaster.Sheets
        sCodeName = ws.CodeName 'Sheet100 to sheet118
        dict(sCodeName) = ws.Index ' codename to index
       
        ' clear old data
        n = Mid(sCodeName, 6)
        If n >= FIRST_SHEET And n <= LAST_SHEET Then
           
           Set rng = ws.UsedRange
           iLastCol = rng.Column + rng.Columns.Count - 1
           iLastRow = rng.Row + rng.Rows.Count - 1
           If iLastCol >= TARGET_COLNO Then
               Set rng = ws.Range(ws.Cells(TARGET_ROWNO, TARGET_COLNO), ws.Cells(iLastRow, iLastCol))
               rng.Cells.ClearContents
               
           End If
           
        End If
    Next
MsgBox ("data cleared")
    ' scan files
    n = 100
    Do While Len(sFile) > 0
        Set wbData = Workbooks.Open(sFolder & "\" & sFile, ReadOnly:=True) ' updatelink, readonly

        ' open each sheet in turn
        For Each wsData In wbData.Sheets

            ' find the filter column in row 1
            Set rng = wsData.Rows(1).Find(FILTER_COL, LookAt:=xlWhole)
            
            If Not rng Is Nothing Then

                colno = rng.Column
                iLastRow = wsData.Cells(Rows.Count, colno).End(xlUp).Row

                If iLastRow > 1 Then
                    ' range to copy and apply filter to one column
                    Set rng = rng.Resize(iLastRow, 1)
                    'rng.AutoFilter Field:=1, Criteria1:=crit, Operator:=xlFilterValues
                    
                    OFLastCol = wsData.Range("A1").End(xlToRight).Column
                    OFLastRow = wsData.Cells(wsData.Rows.Count, OFLastCol).End(xlUp).Row
                    Set rng = wsData.Range("A1", wsData.Cells(OFLastRow, OFLastCol))
                    rng.AutoFilter Field:=colno, Criteria1:=crit, Operator:=xlFilterValues
                    Set rng = rng.SpecialCells(xlCellTypeVisible)

                     ' is there data to copy
                    If rng.Rows.Count > 1 Or rng.Areas.Count > 1 Then
                       
                        ' check sheet available
                        sCodeName = "Sheet" & n
                        If dict.exists(sCodeName) Then
                            Set wsMaster = wbMaster.Sheets(dict(sCodeName))
                        Else
                            MsgBox sCodeName & " not found", vbCritical
                            Exit Sub
                        End If
                            
                        ' copy / paste all columns of visible rows
                        wsData.UsedRange.SpecialCells(xlCellTypeVisible).Copy
                        With wsMaster.Cells(TARGET_ROWNO, TARGET_COLNO)
                            .PasteSpecial Paste:=xlPasteValues
                        End With
                        'wsMaster.Range("G1").Select
                        'Selection.PasteSpecial Paste:=xlPasteValues, _
                        'Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                        Application.CutCopyMode = False
                        wsMaster.Activate
                        wsMaster.Range("A1").Select
                    Else
                        MsgBox "No data after filter on sheet " & wsData.Name, vbExclamation, wbData.Name
                    End If
                Else
                   MsgBox "No data in column " & colno & " on sheet " & wsData.Name, vbExclamation, wbData.Name
                End If
            Else
                MsgBox FILTER_COL & " not found on sheet " & wsData.Name, vbExclamation, wbData.Name
            End If
            n = n + 1 ' next data sheet
        Next
        wbData.Close False
        sFile = Dir() ' next file in folder
    Loop

    MsgBox sFolder & " files scanned for option " & sOption, vbInformation
End Sub
Shanturoy
  • 3
  • 3
  • Because the filter range is only 1 column and `crit` is an array `rng.AutoFilter Field:=colno, Criteria1:=Array(crit), Operator:=xlFilterValues` should be `rng.AutoFilter Field:=1, Criteria1:=crit, Operator:=xlFilterValues` – CDP1802 Mar 17 '21 at 10:10
  • @CDP1802 Your Update 2 code worked without error, but for some of the data sheets, it is not filtering on the "Vertical" column, but the 1st available column, hence ending up with no data. Also, even if there is no data, can it move to the next sheet after clearing the available data in the target ? Feel that we are very close to the final code – Shanturoy Mar 17 '21 at 11:15
  • To move to next sheet regardless move the `n=n+1` and `Set wsMaster = wsMaster.Next` to end of loop after `sFile = Dir()`. The selection of the 1st column problem on some sheets is a puzzle. What value is in the header row of that column as an example. – CDP1802 Mar 17 '21 at 11:30
  • I am using the code you have updated (Update 2), and there I dont see the line Set wsMaster = wsMaster.Next . For the filter issue I tried passing the variable "colno" to the autofliter command - "rng.AutoFilter Field:=colno,Criteria1:=crit, Operator:=xlFilterValues but that made the macro crawl copying 1 row at a time for 21K rows effectively freezing excel again. can we add the exact match criteria for to the find command? @CDP1802 – Shanturoy Mar 17 '21 at 14:55
  • I was referring to your code but it should have been move to before the last `next`. The option on `Find` are [here](https://learn.microsoft.com/en-us/office/vba/api/Excel.Range.Find). The AutoFilter column number in relative to the filtered range. Because only one column is filtered the number must be 1. See my updated code. – CDP1802 Mar 17 '21 at 15:28
  • @CPD1802, yes I guessed so, but thei I saw that it set the filter on the 1st col for the 1st data sheet it opened, so though it may be an issue somehow. I tried to modify the code a but, please check that code and let me know what you think. I have mentioned the issue I am facing too. Again, thanks a lot for having your patience with me. A little learning is a dangerous thing. So I am a very dangerous person right now :) – Shanturoy Mar 18 '21 at 12:01
  • This code is working fully!!! just ran with the Do While loop, and worked. Only problem is that it is taking a huge amount of time to copy the data. Over 1 hour to copy all the files !!! – Shanturoy Mar 18 '21 at 13:57