macro wont select requested selection

[kl88]

Hey everyone,

Im having again a slight problem with my macro. Yesterday i got it to work through the help of some nice people here. But now since i have expended the macro it wont work anymore. Maybe someone here is able to tell me whats wrong with it.

Sub SubtotaalName1()
'
' Subtotaal name1'
    Sheets(1).Select
    On Error Resume Next
    Set wSheet = Sheets("name1")
        If wSheet Is Nothing Then 'Doesn't exist
        Set wSheet = Nothing
        On Error GoTo 0
        Else 'Does exist
 
'Subtotaal ter goedkeuring verstuurd aan DM
    ActiveSheet.Range("$B$1:$BC$12").AutoFilter Field:=25, Criteria1:= _
        "name1"
    ActiveSheet.Range("$B$1:$BC$12").AutoFilter Field:=24, Criteria1:= _
        "Ter goedkeuring verstuurd aan DM"
 
    Set rRange = Range("B2", Range("B65536").End(xlUp).Offset(1)).Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    If Selection.Cells.Count < 1 Then
    Exit Sub
    Else
    If Selection.Cells.Count = 1 Then
    ActiveRow = ActiveCell.Row 'gets row address of active cell
    Range(Cells(ActiveRow, 2), Cells(ActiveRow, 24)).Select
    Else
    [COLOR=red]Selection.SpecialCells(xlCellTypeVisible).Resize(, 25).Select[/COLOR]
    
    End If
    End If
'Copy found codes
    Selection.Copy
 
    Sheets("name1").Select
    'Select first empty cel in A column
    If IsEmpty(Range("A2")) Then
    Range("A2").Select
    Set Imputhere = ActiveCell
    Else
    Range("A1").End(xlDown).Select
    Selection.Offset(1, 0).Select
    Set Imputhere = ActiveCell
    End If
    'Kopieer cells into new sheet
    ActiveCell.FormulaR1C1 = "Ter goedkeuring verstuurd aan DM
"
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Selection.Columns.AutoFit
    Range("A65536").End(xlUp).Offset(1, 0).Select
    ActiveRow = ActiveCell.Row 'gets row address of active cell
    Range(Cells(ActiveRow, 1), Cells(ActiveRow, 25)).Select
    Application.CutCopyMode = False
    'Color subtotaal balk
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    'Merge A tot D
    Range(Cells(ActiveRow, 1), Cells(ActiveRow, 4)).Select
    Selection.Merge
    Selection.Font.Bold = True
    ActiveCell.FormulaR1C1 = "Subtotaal"
    '-------------------------------------------------------------------------
    'Subtotaal ter goedkeuring verstuurd aan RH
    Sheets(1).Select
 
    ActiveSheet.Range("$B$1:$BC$12").AutoFilter Field:=25, Criteria1:= _
        "name1"
    ActiveSheet.Range("$B$1:$BC$12").AutoFilter Field:=24, Criteria1:= _
        "Ter goedkeuring verstuurd aan RH"
 
    Set rRange = Range("B2", Range("B65536").End(xlUp).Offset(1)).Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    If Selection.Cells.Count < 1 Then
    Exit Sub
    Else
    If Selection.Cells.Count = 1 Then
    ActiveRow = ActiveCell.Row 'gets row address of active cell
    Range(Cells(ActiveRow, 2), Cells(ActiveRow, 24)).Select
    Else
    [COLOR=red]Selection.SpecialCells(xlCellTypeVisible).Resize(, 25).Select[/COLOR]
    
    End If
    End If
'Copy found codes
    Selection.Copy
 
    Sheets("name1").Select
    'Select first empty cel in A column
    If IsEmpty(Range("A2")) Then
    Range("A2").Select
    Set Imputhere = ActiveCell
    Else
    Range("A1").End(xlDown).Select
    Selection.Offset(1, 0).Select
    Set Imputhere = ActiveCell
    End If
    'Kopieer cells into new sheet
    ActiveCell.FormulaR1C1 = "Ter goedkeuring verstuurd aan RH"
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Selection.Columns.AutoFit
    Range("A65536").End(xlUp).Offset(1, 0).Select
    ActiveRow = ActiveCell.Row 'gets row address of active cell
    Range(Cells(ActiveRow, 1), Cells(ActiveRow, 25)).Select
    Application.CutCopyMode = False
    'Color subtotaal balk
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    'Merge A tot D
    Range(Cells(ActiveRow, 1), Cells(ActiveRow, 4)).Select
    Selection.Merge
    Selection.Font.Bold = True
    ActiveCell.FormulaR1C1 = "Subtotaal"
 
 
        For Each NumRange In Columns("E").SpecialCells(xlConstants, xlNumbers).Areas
        SumAddr = NumRange.Address(False, False)
        NumRange.Offset(NumRange.Count, 0).Resize(1, 1).Formula = "=SUM(" & SumAddr & ")"
        c = NumRange.Count
    Next NumRange
 
NoData:
    Sheets(1).Select
    'Turn of filter
    ActiveSheet.Range("$B$1:$BC$12").AutoFilter Field:=25
    ActiveSheet.Range("$B$1:$BC$12").AutoFilter Field:=24
 
End If
End Sub

so the red part is the problem, it will select the codes. but it wont select all the columns behind it anymore..
Anyone know whats up with it ??

Any help is appreciated !!

 

[Weaver]

specialcells(xlcelltypevisible)

will error out if there are no visible cells to select. If there's an error trap, this will get activated.

 

[kl88]

Hm.. i dont quite get it. Im sure there are visible cells to select.
Cuz thats the whole point, i want it to select only the visable cells. And at first it worked. But then i added a whole bit on the end of the macro for a different sheet , and now it just selects the codes thru the filter, but not all the columns i need behind it.