bluepenink
Well-known Member
- Joined
- Dec 21, 2010
- Messages
- 585
Hello
the following macro i have copies data from my "master" worksheet and creates new worksheets based on column "I" where "I" is the sales ppl positions. basically, it filters and creates new worksheets based on positions to help us sort data out quicker.
the only issue is, i inserted new columns so my range is from A-R. the new columns i created are N, P, R
for some reason however, it copies all the data, except for the data in from the new columns. can someone pls help me with this issue!
thx you so much!
the following macro i have copies data from my "master" worksheet and creates new worksheets based on column "I" where "I" is the sales ppl positions. basically, it filters and creates new worksheets based on positions to help us sort data out quicker.
the only issue is, i inserted new columns so my range is from A-R. the new columns i created are N, P, R
for some reason however, it copies all the data, except for the data in from the new columns. can someone pls help me with this issue!
Code:
Option Explicit
Sub FilterCities()
'consolidated employees by current role - hhaque
Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long
Dim colWidths(20) As Variant
Dim cwlc As Long ' column width loop counter
'include bottom most header row
Const TopLeftCellOfDataBase As String = "A8"
'what column has your key values
Const KeyColumn As String = "I"
'where's your data
Set DataBaseWks = Worksheets("Master")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1
With DataBaseWks
For cwlc = 1 To 20
colWidths(cwlc) = .Columns(cwlc).ColumnWidth
Next cwlc
End With
rsp = MsgBox("Include headings?", vbYesNo, "Filter by current role")
Application.ScreenUpdating = False
Set TempWks = Worksheets.Add
With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With
'rebuild the List
With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True
'Add the heading to the criteria area
TempWks.Range("D1").Value = _
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With
With TempWks
Set ListRange = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))
End With
With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With
'check for individual City worksheets
For Each myCell In ListRange.Cells
If WksExists(myCell.Value) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = myCell.Value
If Err.Number = 5 Then
MsgBox "Please rename: " & wks.Name
Err.Clear
End If
On Error GoTo 0
wks.Move After:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(myCell.Value)
wks.Cells.Clear
End If
If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
End If
'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value & Chr(34)
'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
With wks
For cwlc = 1 To 20
.Columns(cwlc).ColumnWidth = colWidths(cwlc)
Next cwlc
ActiveWindow.DisplayGridlines = Not ActiveWindow.DisplayGridlines
' new code
With .PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = "&""Arial,Regular""&8DRAFT"
.LeftFooter = "&""Arial,Regular""&8&F"
.CenterFooter = "&""Arial,Regular""&8Confidential"
.RightFooter = "&""Arial,Regular""&8Page: &P of &N"
.LeftMargin = Application.InchesToPoints(0.17)
.RightMargin = Application.InchesToPoints(0.17)
.TopMargin = Application.InchesToPoints(0.24)
.BottomMargin = Application.InchesToPoints(0.26)
.HeaderMargin = Application.InchesToPoints(0.17)
.FooterMargin = Application.InchesToPoints(0.16)
.Orientation = xlPortrait
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
' end of new code
End With
Next myCell
Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Employees filtered by current role complete"
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Functionthx you so much!
