Extracting Values based on Filtering

[Ildestino]

Dear VBA/Excel Gurus,

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

As an example:

Continent	Country	City	Currency
Europe	Austria	Vienna	EUR
Europe	Russia	Moskau	RUB
Europe	Germany	Berlin	EUR
Europe	Belarus	Minsk	RUB
Africa	Senegal	Dakar	XOF
Africa	Togo	Lome	XOF

<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

Continent	Country	City	Currency
Europe	Austria	Vienna	EUR
Europe	Germany	Berlin	EUR

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

Second Workbook: File Name: RUB.xlsx

Continent	Country	City	Currency
Europe	Russia	Moskau	RUB
Europe	Belarus	Minsk	RUB

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

Third Workbook: File Name: XOF.xlsx

Continent	Country	City	Currency
Africa	Senegal	Dakar	XOF
Africa	Togo	Lome	XOF

<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

 

[dmt32]

Hi,
give following a try & see if does what you want:


Place ALL code in a STANDARD module.

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]

Hi,
give following a try & see if does what you want:


Place ALL code in a STANDARD module.

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]

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