VBA Code to Freeze Top Row and Apply Filter to Columns

[jski]

So I have a macro that filters data on a selected column and creates a new worksheet for it. Works well. A few extra bits would be helpful; particularly if after the data filtering process the macro could freeze the top row and add a filter to each column. Would save moi a ton of time. I've tried a few things but have come up empty or receive VBA errors. Here's the code:


Option Explicit
'Generates an inputbox to select column containing desired extraction criteria'
'and creates separate tab with headings for each unique criteria found.
'Assumes headings are in row 1 of master data sheet.'

Sub FilterData()
Dim ws1Master As Worksheet, wsNew As Worksheet, wsFilter As Worksheet
Dim Datarng As Range, FilterRange As Range, objRange As Range
Dim rowcount As Long
Dim colcount As Integer, FilterCol As Integer
Dim SheetName As String
Dim wkSt As String
Dim wkBk As Worksheet

'master sheet
Set ws1Master = ActiveSheet
'set the Column you are filtering'
top:
On Error Resume Next
Set objRange = Application.InputBox("Select One Column Only To Filter", "Range Input", , , , , , 8)
On Error GoTo 0
If objRange Is Nothing Then
Exit Sub
ElseIf objRange.Columns.Count > 1 Then
GoTo top
End If
FilterCol = objRange.Column
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
On Error GoTo progend
'add filter sheet
Set wsFilter = Sheets.Add
With ws1Master
.Activate
.Unprotect Password:="" 'add password if needed
rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
colcount = .Cells(1, .Columns.Count).End(xlToLeft).Column
If FilterCol > colcount Then
Err.Raise 65000, "", "FilterCol Setting Is Outside Data Range.", "", 0
End If
Set Datarng = .Range(.Cells(1, 1), .Cells(rowcount, colcount))
'extract Unique values from FilterCol
.Range(.Cells(1, FilterCol), _
.Cells(rowcount, _
FilterCol)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=wsFilter.Range("A1"), _
Unique:=True
rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
'set Criteria
wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
'check for blank cell in range
If Len(FilterRange.Value) > 0 Then
'add the FilterRange to criteria
wsFilter.Range("B2").Value = FilterRange.Value
SheetName = RTrim(Left(FilterRange.Value, 31))
'if FilterRange sheet exists
'update it
If SheetExists(SheetName) Then
Sheets(SheetName).Cells.Clear
Else
'add new sheet
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = SheetName
End If
Datarng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=wsFilter.Range("B1:B2"), _
CopyToRange:=Sheets(SheetName).Range("A1"), _
Unique:=False
End If
Next
.Select
End With
progend:
wsFilter.Delete
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
If Err > 0 Then
MsgBox (Error(Err)), vbCritical, "Error"
Err.Clear
End If
'Autofits all columns in new tabs
'Application.ScreenUpdating = False
'wkSt = ActiveSheet.Name
'For Each wkBk In ActiveWorkbook.Worksheets
'On Error Resume Next
'wkBk.Activate
'Cells.EntireColumn.AutoFit
'Next wkBk
Sheets(wkSt).Select
Application.ScreenUpdating = True
End Sub



Thanks in advance for the consideration and assistance.


jski

 

[healey21]

Try this code it will freezepane each worksheet and also add a filter to each sheet

Sub freezeAndFilter()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Activate
With Application.ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
Application.ActiveWindow.FreezePanes = True
If Not ActiveSheet.AutoFilterMode Then
ActiveSheet.Range("A1").AutoFilter
End If
Next ws
End Sub

 

[jski]

Thanks. However it doesn't seem to work. I placed the code at the very end of the above and no luck. I tried grouping all the newly created sheets and running it with no success. Might it need to be placed at an appropriate place in the existing code as a final step once the new worksheet is created? Just a thought.

 

[jski]

So I played a bit more with this and got it to work. Here's what I inserted:

'Freezes the top row
Application.ScreenUpdating = True
Cells(2, 1).Select
ActiveWindow.FreezePanes = True
'formats the data
Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 10
End With
Rows("1:1").Select
With Selection.Font
.Size = 11
Cells.Select
ActiveWindow.Zoom = 90
End With
'Applies data filters
With ActiveSheet
.AutoFilterMode = False
.Range("A1:W1").AutoFilter
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
End With

 

[ddawsonb]

I roam around looking for this same answer, it's easy to do by recording macro and copy/paste into VBA. BUT.... I don't want to have to turn ScreenUpdating back to True. And I have not seen one example where this could be done w/o turning ScreenUpdating 'on' (may not be possible). Does anyone know of a way to freeze row (top) w/o turning 'on' ScreenUpdating? I have a long script running on Workbook with many Sheets where I turn off a few things to make scripts run faster (and keep screen static - even though I do avoid "Select"-ing things...). And I'd rather not cause the screen to change the display just to do this task, then return ScreenUpdating to 'off'...

btw, I did try this by keeping ScreenUpdating False, but does not work correctly. For some reason it freezes at a row about 10-12 rows from top. But same code run with ScreenUpdating = True works fine.