excel - selecting sheets dependant on date in sheet name

[Lee_S]

Hi,

I have a workbook that is made up of 13 sheets, named January to December and one called reports.

Now i have a sub on the report sheet that runs through all the other sheets and copies certain data to the reports sheet in a nice list.

But i want to add a sort of manual filter to the reports list by way of a combobox.

Options will be:
"All Months" - Copy relevant data from all sheets
"Previous Months" - Copy data from sheets PREVIOUS to system date
"Future Months" - Copy all data from sheets AFTER system date

Im sure you get the idea.

I figured the combobox_change event could fire the current sub, and then i'll have a check in there to see what the combo's value is. Any idea how i can incorporate that so it checks the date and matches it to the sheet names?

Here is the current sub.

Private Sub Worksheet_Activate()
Dim rng As Range
Dim lLastRow As Integer
Dim iNextRow As Integer
Dim x As Integer
Dim bFound As Boolean
 
Dim ws As Worksheet
Dim sht_Rpt As Worksheet  'Set a handle for the Reports Sheet
Set sht_Rpt = Sheets("Reports")
 
    sht_Rpt.Rows("7:65536").Delete Shift:=xlUp
    bFound = False
    For Each ws In Worksheets
        If ws.Name <> "Reports" Then
            Set rng = ws.Range("A1").SpecialCells(xlCellTypeLastCell)
            lLastRow = rng.Row
            
            For x = 2 To lLastRow 'First two rows contain headers etc
                If ws.Cells(x, "E").Value = "" And ws.Cells(x, "A").Value <> "" And ws.Cells(x, "E").Interior.ColorIndex = xlNone Then
                    If bFound = False Then
                        bFound = True
                        With sht_Rpt.Cells(FindBottomRow(sht_Rpt, 1), "A")
                            .Font.Bold = True
                            .Value = ws.Name
                        End With
                    End If
                    iNextRow = FindBottomRow(sht_Rpt, 1)
                    sht_Rpt.Range("A" & iNextRow, "D" & iNextRow).Value = ws.Range("A" & x, "D" & x).Value
                    sht_Rpt.Range("E" & iNextRow).Value = ws.Range("G" & x).Value
                End If
            Next x
        End If
        bFound = False
    Next
End Sub

[RobDog888]

Is your combo on the sheet or on a userform? You can use the Select Case block to evaluate the selection and act accordingly using the date funtions.

Private Sub ComboBox1_Change()
    Select Case ComboBox1.Text
        Case "All Months"
            'Blah
        Case "Previous Month"
            Sheets(MonthName(Month(DateAdd("m", -1, Date)))).Activate
            'Blah, Blah...
        Case "Next Month"
            Sheets(MonthName(Month(DateAdd("m", 1, Date)))).Activate
            'Blah, Blah, Blah...
    End Select
End Sub

[Lee_S]

Thanks for the reply.

Combobox is on a sheet.

I dont want it to activate a single sheet as such like your example. Say the user decided to select "Previous Months" and the current month is October.

So the code would run through all the sheets named "January" to "September" and pull the data from them, copying it to the Reports sheet.

Im thinking that maybe in the combobox_change code i have an array and fill it with all the names of the sheets that need to be cycled for the current filter. Then when the combobox is changed the array is wiped and refilled.

Seems a really longwinded way though. There must be something better.

[Lee_S]

Ok, well this is what I've come up with so far. This DOES work, but if you can see where I can improve this code please say. I think the loops definately need some work

Option Explicit
Private sMonth(12) As String
 
Private Sub cmbFilter_Change()
Dim i As Integer
 
Erase sMonth()
Select Case cmbFilter.Text
    Case "Previous Months"
        For i = 1 To Month(Now) - 1
            sMonth(i - 1) = MonthName(i)
        Next
    Case "Previous & Current Months"
        For i = 1 To Month(Now)
            sMonth(i - 1) = MonthName(i)
        Next
    Case "Future Months"
        For i = Month(Now) + 1 To 12
            sMonth(i - 1) = MonthName(i)
        Next
    Case "Current Month"
        sMonth(0) = MonthName(Month(Now))
    Case Else ' All Months
        For i = 1 To 12
            sMonth(i - 1) = MonthName(i)
        Next
End Select
 
Display_Data
 
End Sub
 
Private Sub worksheet_activate()
    cmbFilter.Value = "All Months" ' Reset to all months, ensures up-to-date data
End Sub
 
Private Sub Display_Data()
Dim rng As Range
Dim lLastRow As Integer
Dim iNextRow As Integer
Dim x As Integer
Dim i As Integer
Dim bFound As Boolean
 
Dim ws As Worksheet
Dim sht_Rpt As Worksheet  'Set a handle for the Reports Sheet
Set sht_Rpt = Sheets("Reports")
 
On Error Resume Next
    sht_Rpt.Rows("7:65536").Delete Shift:=xlUp
    bFound = False
    
    For i = 0 To UBound(sMonth)
        If Len(sMonth(i)) > 0 Then
            Set ws = Sheets(sMonth(i))
            Set rng = ws.Range("A1").SpecialCells(xlCellTypeLastCell)
            lLastRow = rng.Row
            
            For x = 2 To lLastRow 'First two rows contain headers etc
                If ws.Cells(x, "E").Value = "" And ws.Cells(x, "A").Value <> "" And ws.Cells(x, "E").Interior.ColorIndex = xlNone Then
                    If bFound = False Then
                        bFound = True
                        With sht_Rpt.Cells(FindBottomRow(sht_Rpt, 1), "A")
                            .Font.Bold = True
                            .Value = ws.Name
                        End With
                    End If
                    iNextRow = FindBottomRow(sht_Rpt, 1)
                    sht_Rpt.Range("A" & iNextRow, "D" & iNextRow).Value = ws.Range("A" & x, "D" & x).Value
                    sht_Rpt.Range("E" & iNextRow).Value = ws.Range("G" & x).Value
                End If
            Next x
        End If
        bFound = False
    Next i
End Sub

This is a funny thing, this line works fine on its own in the worksheet_activate() code, but when i moved it to the display_data() sub it breaks with this error "Delete method of Range class failed". I think this must have something to do with the combobox or something, but i put the error handler above it and the problem goes away.

sht_Rpt.Rows("7:65536").Delete Shift:=xlUp

Any thoughts please?

[RobDog888]

Well I just gave you the logic as a simple example but Lee created a nice example. What happens when your on Janurary and you select previous month? Is it supposed to go to December of the previous year?

[Lee_S]

Well I just gave you the logic as a simple example but Lee created a nice example. What happens when your on Janurary and you select previous month? Is it supposed to go to December of the previous year?

That would be me.. who asked the question :P

Anyway, at this stage no it shouldnt switch between years as the workbook only contains sheets for a single year, next year will be in a different sheet, though i'll have to link them at some point i spose.

At the moment, if i click on previous when in january it just displays the blank page with the headers which is fine.

I appreciate your input, cheers.

lee

[RobDog888]

My mistake! Well you could check what the current Active sheet is and if its Janurary then dont go back. Same logic for when your on December and select Next Months.

[Lee_S]

My mistake! Well you could check what the current Active sheet is and if its Janurary then dont go back. Same logic for when your on December and select Next Months.

No worries. That won't work for this instance as Active Sheet will always be "Reports" wont it? Thats where the combobox is.

It doesn't seem to be throwing out any errors as it is now, do i really need to add more checks to that part?

Have made a change to the loops which has increased speed slightly.

[b]iNextRow = FindBottomRow(sht_Rpt, 1) ' call this only once now[/b]
    For i = 0 To UBound(sMonth)
        If Len(sMonth(i)) > 0 Then
            Set ws = Sheets(sMonth(i))
            Set rng = ws.Range("A1").SpecialCells(xlCellTypeLastCell)
            lLastRow = rng.Row
            
            For x = 2 To lLastRow 'First two rows contain headers etc
                If ws.Cells(x, "E").Value = "" And ws.Cells(x, "A").Value <> "" And ws.Cells(x, "E").Interior.ColorIndex = xlNone Then
                    If bFound = False Then
                        bFound = True
                        [b]With sht_Rpt.Cells(iNextRow, "A")[/b]
                            .Font.Bold = True
                            .Value = ws.Name
                        End With
                        [b]iNextRow = iNextRow + 1 ' increase it as we go so we dont have to keep checking the function[/b]
                    End If
                    sht_Rpt.Range("A" & iNextRow, "D" & iNextRow).Value = ws.Range("A" & x, "D" & x).Value
                    sht_Rpt.Range("E" & iNextRow).Value = ws.Range("G" & x).Value
                    [b]iNextRow = iNextRow + 1[/b]
                End If
            Next x
        End If
        bFound = False
    Next i