FILTER EXCEL PER COUNTRY & CREATE MULTIPLE WORKBOOKS

[sahinbur]

Hi All,

I have list of markets/countries (approx 20) below in the table. :yes
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.

24306

[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.

24317

[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 SubOf 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 ?