FILTER EXCEL PER COUNTRY & CREATE MULTIPLE WORKBOOKS

[sahinbur]

Hi All,

I have list of markets/countries (approx 20) below in the table.
And I would like to create multiple workbooks according to each market with their names where I can see their figures / informations only, with the same style.
My data start from column b to r

I hope I can explain my problem.

Thanks a lot in advance.

Capture.JPG

[Logit]

Can you post a copy of your workbook with a small sample of representative data ? It is difficult looking at the image to determine
rows / columns / header etc.

Do not include any confidential information.

[sahinbur]

Can you post a copy of your workbook with a small sample of representative data ? It is difficult looking at the image to determine
rows / columns / header etc.

Do not include any confidential information.

Hi Logit, Thanks for your reply.
Attached you'll find my sample.

Sample.xlsx

[Logit]

.
Paste in a regular module :

Option Explicit


Sub CreateSheets()


    Dim Cell    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet


        Set RngBeg = Worksheets("sample").Range("D3")
        Set RngEnd = Worksheets("sample").Cells(Rows.Count, "D").End(xlUp)


        ' Exit if the list is empty.
        If RngEnd.Row < RngBeg.Row Then Exit Sub
Application.ScreenUpdating = False
        For Each Cell In Worksheets("sample").Range(RngBeg, RngEnd)
            On Error Resume Next
                ' No error means the worksheet exists.
                Set Wks = Worksheets(Cell.Value)


                ' Add a new worksheet and name it.
                If Wks.Name <> Cell.Value Then
                    Set Wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                    Wks.Name = Cell.Value
                End If
            On Error GoTo 0
        Next Cell
Application.ScreenUpdating = True
MakeHeaders
End Sub


Sub MakeHeaders()
Dim srcSheet As String
Dim dst As Integer
srcSheet = "sample"
Application.ScreenUpdating = False
For dst = 1 To Sheets.Count
    If Sheets(dst).Name <> srcSheet Then
    Sheets(srcSheet).Rows("2:2").Copy
    Sheets(dst).Activate
    Sheets(dst).Range("A1").PasteSpecial xlPasteValues
    Sheets(dst).Range("A1:N1").Interior.Color = RGB(84, 129, 53)
    Sheets(dst).Range("A1:N1").Font.Color = vbWhite
    Sheets(dst).Range("A1:N1").Font.Bold = True
    
    Sheets(dst).Range("A1").Select
    End If
Next
Application.ScreenUpdating = True
CopyData
End Sub


Sub CopyData()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
On Error GoTo M
Lastrow = Sheets("sample").Cells(Rows.Count, "D").End(xlUp).Row
Dim ans As String
    For i = 3 To Lastrow
    ans = Sheets("sample").Cells(i, 4).Value
        Sheets("sample").Rows(i).Copy Sheets(ans).Rows(Sheets(ans).Cells(Rows.Count, "D").End(xlUp).Row + 1)
        Sheets(ans).Columns("A:N").EntireColumn.AutoFit
    Next
Application.ScreenUpdating = True


Sheets("sample").Activate
Sheets("sample").Range("A1").Select


Exit Sub


M:
MsgBox "No such sheet as  " & ans & " exist"
Application.ScreenUpdating = True


End Sub

[p45cal]

I don't know how you want to save the workbooks produced so I've left them open. In the attached there's this macro:

Sub blah()
Application.ScreenUpdating = False
Set SceRng = Range("Table2[#All]")
With Sheets.Add
  .Range("A1,C1").Value = "Country"
  SceRng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("C1"), Unique:=True
  Set myList = .Range("C1").CurrentRegion
  For Each cll In Intersect(myList, myList.Offset(1)).Cells
    .Range("A2").FormulaR1C1 = "=""=" & cll.Value & """"
    Set NewSht = ThisWorkbook.Sheets.Add
    SceRng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("A1:A2"), CopyToRange:=NewSht.Range("A1"), Unique:=False
    NewSht.Columns("A:N").EntireColumn.AutoFit
    NewSht.Name = cll.Value
    NewSht.Move
  Next cll
  Application.DisplayAlerts = False: .Delete: Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
End Sub

[sahinbur]

Hi Logit, Thanks a lot for your help.
when I run the code, message coming "No such sheet as Country 1 exists"
How we sort that out?

[sahinbur]

Hi,

Code works pretty well. Thanks a lot.
But how can we save them to the predefined folder with the name of the country that should be the name of the workbook.

[sahinbur]

I don't know how you want to save the workbooks produced so I've left them open. In the attached there's this macro:

Sub blah()
Application.ScreenUpdating = False
Set SceRng = Range("Table2[#All]")
With Sheets.Add
  .Range("A1,C1").Value = "Country"
  SceRng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("C1"), Unique:=True
  Set myList = .Range("C1").CurrentRegion
  For Each cll In Intersect(myList, myList.Offset(1)).Cells
    .Range("A2").FormulaR1C1 = "=""=" & cll.Value & """"
    Set NewSht = ThisWorkbook.Sheets.Add
    SceRng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("A1:A2"), CopyToRange:=NewSht.Range("A1"), Unique:=False
    NewSht.Columns("A:N").EntireColumn.AutoFit
    NewSht.Name = cll.Value
    NewSht.Move
  Next cll
  Application.DisplayAlerts = False: .Delete: Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
End Sub

Hi,

Code works pretty well. Thanks a lot.
But how can we save them to the predefined folder with the name of the country that should be the name of the workbook.

[p45cal]

how can we save them to the predefined folder with the name of the country that should be the name of the workbook.[/COLOR]

Assuming each country name is a valid filename, then something like:

Sub blah()
Application.ScreenUpdating = False
Set SceRng = Range("Table2[#All]")
With Sheets.Add
  .Range("A1,C1").Value = "Country"
  SceRng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("C1"), Unique:=True
  Set myList = .Range("C1").CurrentRegion
  For Each cll In Intersect(myList, myList.Offset(1)).Cells
    .Range("A2").FormulaR1C1 = "=""=" & cll.Value & """"
    Set NewSht = ThisWorkbook.Sheets.Add
    SceRng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("A1:A2"), CopyToRange:=NewSht.Range("A1"), Unique:=False
    NewSht.Columns("A:N").EntireColumn.AutoFit
    'NewSht.Name = cll.Value 'optional
    NewSht.Move
    ActiveWorkbook.Close True, "C:\Users\Public\Documents\" & cll.Value & ".xlsx"
  Next cll
  Application.DisplayAlerts = False: .Delete: Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
End Sub

Of course, you should adjust "C:\Users\Public\Documents" to your predefined folder.

[Logit]

.
Downloading the attached example workbook .. I am unable to recreate the issue here. It runs as intended.

Did you change anything in the code or change the name of the sheet tab "sample" to something else ?