Extracting Values based on Filtering

Ildestino

New Member
Joined
Jun 23, 2014
Messages
15
Dear VBA/Excel Gurus,

I would like to create series of reports based on common values.

As an example:

ContinentCountryCityCurrency
EuropeAustriaViennaEUR
EuropeRussiaMoskauRUB
EuropeGermanyBerlinEUR
EuropeBelarusMinskRUB
AfricaSenegalDakarXOF
AfricaTogoLomeXOF

<colgroup><col><col><col><col></colgroup><tbody>
</tbody>


So basically, What I would like to achieve would be a VBA coding to produce Workbooks based on the Currency filter:

Example Results:

First Workbook: File Name: EUR.xlsx

ContinentCountryCityCurrency
EuropeAustriaViennaEUR
EuropeGermanyBerlinEUR

<colgroup><col width="64" span="4" style="width:48pt"> </colgroup><tbody>
</tbody>

Second Workbook: File Name: RUB.xlsx

ContinentCountryCityCurrency
EuropeRussiaMoskauRUB
EuropeBelarusMinskRUB

<colgroup><col width="64" span="4" style="width:48pt"> </colgroup><tbody>
</tbody>


Third Workbook: File Name: XOF.xlsx

ContinentCountryCityCurrency
AfricaSenegalDakarXOF
AfricaTogoLomeXOF

<colgroup><col width="64" span="4" style="width:48pt"> </colgroup><tbody>
</tbody>


and so on and so on. Is there any possibility doing this job via excel? It would probably deal with at least 50k rows (the whole report).

Many thanks for ideas, hints and almost anything :)

Kind regards

Ildestino
 

Some videos you may like

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,388
Office Version
  1. 2019
Platform
  1. Windows
Hi,
give following a try & see if does what you want:


Place ALL code in a STANDARD module.

Rich (BB code):
Sub CreateWorkBooks()
    Dim wsMaster As Worksheet, wsFilter As Worksheet
    Dim wbNew As Workbook
    Dim DataRange As Range, c As Range
    Dim FolderPath As String, msg As String
    Dim FilterColumn As Variant, MasterSheet As String
    Dim lr As Long, lc As Long
    Dim HeaderRow As Integer


    '********************************************************************************************
    '******************************************SETTINGS******************************************
    
    FolderPath = "C:\MyFolder\"     '< this is where files are saved
                                               'change folder path as required
                            
    FilterColumn = 4                    '< Criteria column to Filter
    
    MasterSheet = "Master"          '< Master Sheet name
    
    HeaderRow = 1                     '<row with headings
    
    '*******************************************************************************************


    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
    
    If Dir(FolderPath, vbDirectory) = vbNullString Then


        msg = MsgBox("Folder Path: " & FolderPath & Chr(10) & Chr(10) & _
                     "Cannot Be Found         ", 16, "Warning")


        Exit Sub


    End If
    
    On Error GoTo exitsub
    
     With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
     End With


    'worksheet where your data is stored
    Set wsMaster = ThisWorkbook.Worksheets(MasterSheet)


    'temp filter sheet
    Set wsFilter = Worksheets.Add
   
    With wsMaster


        lr = .Cells(.Rows.Count, FilterColumn).End(xlUp).Row
        lc = .Cells(HeaderRow, .Columns.Count).End(xlToLeft).Column


       
        Set DataRange = .Range(.Cells(HeaderRow, 1), .Cells(lr, lc))


    
'extract list to filter sheet
        .Columns(FilterColumn).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=wsFilter.Range("A1"), Unique:=True


        lr = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row


'set up Criteria Area
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
        
        For Each c In wsFilter.Range("A2:A" & lr)
        If Len(c) > 0 Then
'add the name to the criteria area
            wsFilter.Range("B2").Value = c.Value


'add new workbook and run advanced filter
            Set wbNew = Workbooks.Add(1)


            wbNew.Sheets(1).Name = c.Value
            
            msg = msg & c.Value & Chr(10)


            DataRange.AdvancedFilter Action:=xlFilterCopy, _
                               CriteriaRange:=wsFilter.Range("B1:B2"), _
                               CopyToRange:=wbNew.Sheets(1).Range("A1"), _
                               Unique:=False
                               
            wbNew.Sheets(1).UsedRange.Columns.AutoFit
            
            SaveNewFile wb:=wbNew, FolderName:=FolderPath, FileName:=c.Value


            wbNew.Close False
        End If
            Set wbNew = Nothing
        Next
        .Activate
    End With
    
    wsFilter.Delete


exitsub:
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
     End With
    If Err > 0 Then
        If Not wbNew Is Nothing Then wbNew.Close False
        MsgBox (Error(Err)), 48, "Error"
    Else
        MsgBox "The Following Files Have Been Created:" & Chr(10) & _
        "Folder Path: " & FolderPath & Chr(10) & _
        "Files Created:" & Chr(10) & msg
    End If
End Sub


Private Sub SaveNewFile(ByVal wb As Workbook, ByVal FolderName As String, ByVal FileName As String)


    Dim NewFileName As String, FileExt As String
    Dim FileFormatIndex As Integer, x As Integer
    Dim myarray()
    
'check for illegal characters
    myarray = Array("<", ">", "|", "/", "*", "\", "?", """")
    For x = LBound(myarray) To UBound(myarray)
        FileName = Replace(FileName, myarray(x), "_", 1)
    Next x


    If Val(Application.Version) < 12 Then
'Excel Files 1997-2003 (*.xls)
        FileFormatIndex = -4143
        FileExt = ".xls"
    Else
'Excel Files 2007 > (*.xlsx)
        FileFormatIndex = 51
        FileExt = ".xlsx"
    End If


    NewFileName = FolderName & FileName & FileExt


    wb.SaveAs FileName:=NewFileName, FileFormat:=FileFormatIndex, Password:="", _
              WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False


End Sub


You will need to change the settings values shown in RED as required.

When run, code should filter master sheet based on required column (D?) values & create & save a new workbook with filter value name.

Hope Helpful

Dave
 

Ildestino

New Member
Joined
Jun 23, 2014
Messages
15
Hi,
give following a try & see if does what you want:


Place ALL code in a STANDARD module.

Rich (BB code):
Sub CreateWorkBooks()
    Dim wsMaster As Worksheet, wsFilter As Worksheet
    Dim wbNew As Workbook
    Dim DataRange As Range, c As Range
    Dim FolderPath As String, msg As String
    Dim FilterColumn As Variant, MasterSheet As String
    Dim lr As Long, lc As Long
    Dim HeaderRow As Integer


    '********************************************************************************************
    '******************************************SETTINGS******************************************
    
    FolderPath = "C:\MyFolder\"     '< this is where files are saved
                                               'change folder path as required
                            
    FilterColumn = 4                    '< Criteria column to Filter
    
    MasterSheet = "Master"          '< Master Sheet name
    
    HeaderRow = 1                     '<row with="" headings
    
    '*******************************************************************************************


    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
    
    If Dir(FolderPath, vbDirectory) = vbNullString Then


        msg = MsgBox("Folder Path: " & FolderPath & Chr(10) & Chr(10) & _
                     "Cannot Be Found         ", 16, "Warning")


        Exit Sub


    End If
    
    On Error GoTo exitsub
    
     With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
     End With


    'worksheet where your data is stored
    Set wsMaster = ThisWorkbook.Worksheets(MasterSheet)


    'temp filter sheet
    Set wsFilter = Worksheets.Add
   
    With wsMaster


        lr = .Cells(.Rows.Count, FilterColumn).End(xlUp).Row
        lc = .Cells(HeaderRow, .Columns.Count).End(xlToLeft).Column


       
        Set DataRange = .Range(.Cells(HeaderRow, 1), .Cells(lr, lc))


    
'extract list to filter sheet
        .Columns(FilterColumn).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=wsFilter.Range("A1"), Unique:=True


        lr = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row


'set up Criteria Area
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
        
        For Each c In wsFilter.Range("A2:A" & lr)
        If Len(c) > 0 Then
'add the name to the criteria area
            wsFilter.Range("B2").Value = c.Value


'add new workbook and run advanced filter
            Set wbNew = Workbooks.Add(1)


            wbNew.Sheets(1).Name = c.Value
            
            msg = msg & c.Value & Chr(10)


            DataRange.AdvancedFilter Action:=xlFilterCopy, _
                               CriteriaRange:=wsFilter.Range("B1:B2"), _
                               CopyToRange:=wbNew.Sheets(1).Range("A1"), _
                               Unique:=False
                               
            wbNew.Sheets(1).UsedRange.Columns.AutoFit
            
            SaveNewFile wb:=wbNew, FolderName:=FolderPath, FileName:=c.Value


            wbNew.Close False
        End If
            Set wbNew = Nothing
        Next
        .Activate
    End With
    
    wsFilter.Delete


exitsub:
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
     End With
    If Err > 0 Then
        If Not wbNew Is Nothing Then wbNew.Close False
        MsgBox (Error(Err)), 48, "Error"
    Else
        MsgBox "The Following Files Have Been Created:" & Chr(10) & _
        "Folder Path: " & FolderPath & Chr(10) & _
        "Files Created:" & Chr(10) & msg
    End If
End Sub


Private Sub SaveNewFile(ByVal wb As Workbook, ByVal FolderName As String, ByVal FileName As String)


    Dim NewFileName As String, FileExt As String
    Dim FileFormatIndex As Integer, x As Integer
    Dim myarray()
    
'check for illegal characters
    myarray = Array("<", ">", "|", "/", "*", "\", "?", """")
    For x = LBound(myarray) To UBound(myarray)
        FileName = Replace(FileName, myarray(x), "_", 1)
    Next x


    If Val(Application.Version) < 12 Then
'Excel Files 1997-2003 (*.xls)
        FileFormatIndex = -4143
        FileExt = ".xls"
    Else
'Excel Files 2007 > (*.xlsx)
        FileFormatIndex = 51
        FileExt = ".xlsx"
    End If


    NewFileName = FolderName & FileName & FileExt


    wb.SaveAs FileName:=NewFileName, FileFormat:=FileFormatIndex, Password:="", _
              WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False


End Sub


You will need to change the settings values shown in RED as required.

When run, code should filter master sheet based on required column (D?) values & create & save a new workbook with filter value name.

Hope Helpful

Dave


Sir, words cannot describe how much you helped me!!!! Thank you very much!!! it is working!!!</row>
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,388
Office Version
  1. 2019
Platform
  1. Windows
Sir, words cannot describe how much you helped me!!!! Thank you very much!!! it is working!!!


Most welcome & glad solution helped you.

Many thanks for your feedback it is very much appreciated.

Dave
 

Watch MrExcel Video

Forum statistics

Threads
1,123,270
Messages
5,600,635
Members
414,398
Latest member
dhune

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top