View Full Version : FILTER EXCEL PER COUNTRY & CREATE MULTIPLE WORKBOOKS
sahinbur
05-30-2019, 02:37 PM
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
05-31-2019, 08:09 AM
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
06-02-2019, 03:23 AM
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
06-02-2019, 09:37 AM
.
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
06-02-2019, 01:18 PM
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
06-03-2019, 12:35 AM
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
06-03-2019, 12:51 AM
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
06-03-2019, 12:51 AM
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
06-03-2019, 02:13 AM
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
06-03-2019, 08:03 AM
.
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 ?
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.