Macro with Filter Issue

Robert13

New Member
Joined
Apr 16, 2013
Messages
16
I am trying to generate two reports. There are 50 divisions. In the first grouping, 4 divisions are shown as listed in red below. This macro is working well for my purposes. However, when I do the same sort of thing to run the other report, the array of the other 46 divisions is too many (i get an error). The listing of the other 46 also changes frequently so I can't do a one time list. What I was trying to do was in the filter select all and then deselect the 4 that are not part of this report. I hope I was able to explain this properly. Any help would be appreciated. Thank you.


Sub Sixty_Day_On()
'
' Sixty_Day_On_BC Macro
'


'
Range("C2").Select
ActiveSheet.Range("$A$5:$AN$600").AutoFilter Field:=3, Criteria1:=Array( _
"Central", "East", "Schedule", "BC-East F/E", "BC-West"), Operator:= _
xlFilterValues
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 15
ActiveWindow.ScrollColumn = 16
ActiveWindow.ScrollColumn = 17
ActiveWindow.ScrollColumn = 18
ActiveWindow.ScrollColumn = 19
ActiveWindow.ScrollColumn = 20
ActiveWindow.ScrollColumn = 21
Range("A5:az700").Select
Selection.Sort Key1:=Range("W1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A2").Select
Columns("X:X").Select
With Selection
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("AB2").Select
ActiveWindow.ScrollColumn = 20
ActiveWindow.ScrollColumn = 19
ActiveWindow.ScrollColumn = 18
ActiveWindow.ScrollColumn = 17
ActiveWindow.ScrollColumn = 16
ActiveWindow.ScrollColumn = 15
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
Columns("C:D").Select
Selection.EntireColumn.Hidden = True
Columns("G:J").Select
Selection.EntireColumn.Hidden = True
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 15
ActiveWindow.ScrollColumn = 16
ActiveWindow.ScrollColumn = 17
ActiveWindow.ScrollColumn = 18
ActiveWindow.ScrollColumn = 19
ActiveWindow.ScrollColumn = 20
Columns("U:U").Select
Selection.EntireColumn.Hidden = True
Columns("Y:AB").Select
Selection.EntireColumn.Hidden = True
Columns("AC:AI").Select
Selection.EntireColumn.Hidden = True
ActiveWindow.ScrollColumn = 30
ActiveWindow.ScrollColumn = 29
ActiveWindow.ScrollColumn = 23
ActiveWindow.ScrollColumn = 22
ActiveWindow.ScrollColumn = 20
ActiveWindow.ScrollColumn = 19
ActiveWindow.ScrollColumn = 18
ActiveWindow.ScrollColumn = 17
ActiveWindow.ScrollColumn = 16
ActiveWindow.ScrollColumn = 15
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("South Region Schedule").Copy Before:=Sheets(1)
Sheets("South Region Schedule (2)").Name = "Monthly Schedule BC"
Range("S1:T602,A1:R602,u1:x602").Select
Dim c As Range
For Each c In Selection.SpecialCells(xlCellTypeVisible)
c.Value = c.Value
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Range("X2:X3,E2:e2").Select
Selection.ClearContents
ActiveWindow.Zoom = 90
Sheets(1).Buttons.Delete
Range("A1").Select
Sheets("Monthly Schedule BC").Select
Sheets("Monthly Schedule BC").Move
End Sub
 

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.
Having a hard time setting up the string and where to insert into the code. I have a vlookup column with all divisions. I could paste value this column and set as a list as part of the macro. How do I put into the code above? Any help is appreciated.
 
Upvote 0
You would want to add the code after the Dims but before the "With". The list could even be passed into the sub as a parameter.

To built the list from a column of values, I would do a quick For... Next with assigning them to a string similar as follows:
Code:
For i = 1 to .Range("C" & rows.count).End(xlUp)
zoneList = zoneList & ", " & .Range("C" & i).End(xlUp).Value
Next i
 
Upvote 0
I think it's over my head. Below is the latest. My macro is blowing up at start. I don;t think I understand the list compilation or the array.


Sixty_Day_On_Commercial_ Macro
'


'
Dim paramArr() As String
Dim listZones As String
Dim enteredValue As Boolean
Dim k As Long
For i = 1 To Range("C6:C600" & Rows.Count).End(xlUp)
zonelist = zonelist & ", " & Range("C6:c600" & i).End(xlUp).Value
Next i
With Range("C6:c600")
For Each zone In zonelist
'Acquire the list somehow...
If Len(Join(paramArr)) <= 0 Then
ReDim Preserve paramArr(0) ' Adjust array size up by one row
paramArr(0) = zone ' Record in array
Else
' Check for existence in array - add only once
For k = 0 To UBound(paramArr) ' Array is zero-based
If zone = paramArr(k) Then
enteredVal = True
End If
Next k
If Not enteredVal Then
ReDim Preserve paramArr(UBound(paramArr) + 1) ' Adjust array size up by one row
paramArr(UBound(paramArr)) = .Range("A" & i).Value ' Record in array
End If
End If
Next zone
ActiveSheet.Range("$A$5:$AN$600").AutoFilter Field:=3, Criteria1:=Array( _
"Central", "East", "Schedule", "East", "West"), Operator:= _
xlFilterValues
End With
Range("A5:az700").Select
Selection.Sort Key1:=Range("W1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
With Columns("X:X")
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("C:D").EntireColumn.Hidden = True
Columns("G:J").EntireColumn.Hidden = True
Columns("U:U").EntireColumn.Hidden = True
Columns("Y:AB").EntireColumn.Hidden = True
Columns("AC:AI").EntireColumn.Hidden = True
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("South Region Schedule").Copy Before:=Sheets(1)
Sheets("South Region Schedule (2)").Name = "Monthly Schedule"
Range("S1:T602,A1:R602,u1:x602").Select
Dim c As Range
For Each c In Selection.SpecialCells(xlCellTypeVisible)
c.Value = c.Value
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Range("X2:X3,E2:e2").ClearContents
ActiveWindow.Zoom = 90
Sheets(1).Buttons.Delete
Sheets("Monthly Schedule").Move
Range("A1").Select

End Sub
 
Upvote 0
I spent a little more time building it for you, but it is still untested and will need debugging:
Code:
Option Explicit

Sixty_Day_On_Commercial_ Macro
    Dim paramArr() As String
    Dim zoneArray() As String
    Dim listZones As String
    Dim enteredValue As Boolean
    Dim k As Long
    Dim i As Long
    Dim lastRow As Long
    
    With Activesheet.Range("C6:c600")
        lastRow = Activesheet.Range("C6:C600" & Rows.Count).End(xlUp)
    
        For i = 1 To lastRow    ' Build list - an array makes this easier
            listZones = listZones & ", " & Activesheet.Range("C6:c600" & i).Value
        Next i
        
        zoneArray = Split(listZones, ", ")
    
        For Each zone In zoneArray
            If Len(Join(paramArr)) <= 0 Then
                ReDim Preserve paramArr(0) ' Adjust array size up by one row
                paramArr(0) = zone ' Record in array
            Else
                ' Check for existence in array - add only once
                For k = 0 To UBound(paramArr) ' Array is zero-based
                    If zone = paramArr(k) Then
                        enteredVal = True
                    End If
                Next k
                If Not enteredVal Then
                    ReDim Preserve paramArr(UBound(paramArr) + 1) ' Adjust array size up by one row
                    paramArr(UBound(paramArr)) = .Range("A" & i).Value ' Record in array
                End If
            End If
        Next zone
        ActiveSheet.Range("$A$5:$AN$600").AutoFilter Field:=3, Criteria1:=Array( _
            "Central", "East", "Schedule", "East", "West"), Operator:= _
            xlFilterValues
    End With    ' Range("C6:c600")
    
    Range("A5:az700").Sort Key1:=Range("W1"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    With Columns("X:X")
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("C:D").EntireColumn.Hidden = True
    Columns("G:J").EntireColumn.Hidden = True
    Columns("U:U").EntireColumn.Hidden = True
    Columns("Y:AB").EntireColumn.Hidden = True
    Columns("AC:AI").EntireColumn.Hidden = True
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheets("South Region Schedule").Copy Before:=Sheets(1)
    Sheets("South Region Schedule (2)").Name = "Monthly Schedule"
    Range("S1:T602,A1:R602,u1:x602").Select
    Dim c As Range
    For Each c In Selection.SpecialCells(xlCellTypeVisible)
        c.Value = c.Value
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Range("X2:X3,E2:e2").ClearContents
    ActiveWindow.Zoom = 90
    Sheets(1).Buttons.Delete
    Sheets("Monthly Schedule").Move
    Range("A1").Select
End Sub

Remember to use code tags to make your code readable. Many bypass your question if it is too hard to read.
 
Upvote 0
James - I appreciate all your help. I still had some trouble debugging and went with a more unsophisticated approach. I put an if statement on my column and if it is a member of the 4 divisions, I made it a 1, if a member of the other 46 a 2. The array is then either one or two. I know this is very simplistic but I can work with it. Thanks again for all the help.
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,238
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top