Knop toevoegen aan macro

Status
Niet open voor verdere reacties.

kroesjhoar

Gebruiker
Lid geworden
4 okt 2011
Berichten
37
Ik zit wederom met een probleem. Ik heb de macro zelf nog verder uitgebreid. Nu zodat elke kolom automatisch de juiste breedte heeft ( maar volgens mij kan de macro hiervoor vele malen korter )
Ook heb ik een voorwaardelijke opmaak en een sortering op kleur toegepast ( ook deze kan volgens mij vele malen korter, maar ik heb geen idee hoe)

Maar het probleem waar ik nu mee zit is. Dat ik een knop heb toegevoegd op het eerste werkblad. Deze werkt naar behoren, maar er wordt vervolgens ook een knop gemaakt op het tweede tabblad. Dit is niet de bedoeling.

Heeft iemand een idee hoe dit op te lossen?

Bestand is hier terug te vinden.
http://www.mijnbestand.nl/Bestand-V87WZMMXQXT3.xlsm
 
Je code iets korter gemaakt.
En de knop wordt verborgen, en terug gezet.

Code:
Sub test()
Dim iWrd As Integer
 Dim sZK As String
 Application.ScreenUpdating = False
    For iWrd = 1 To 4
        sZK = Application.WorksheetFunction.Choose(iWrd, "OK", "BLOK", "QUAR", "AFK")
        Range("A1:Z2000").AutoFilter 9, sZK
        
      With Sheets(1).Shapes(1)
      If .Visible = True Then
      .Visible = False
      End If
      End With
      
        Range("A1:Z2000").SpecialCells(xlCellTypeVisible).Copy Worksheets(sZK).Range("A1")
    
    With Sheets(sZK)
        .Columns.AutoFit
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("M1:M900") _
            , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .Sort.SortFields.Add(Range("M1:M900"), _
            xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(192, 0 _
            , 0)
     End With
    
    With ActiveWorkbook.Worksheets(sZK).Sort
        .SetRange Range("A1:P900")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
      End With
    Next
   Range("A1:Z2000").AutoFilter
 Sheets(1).Shapes(1).Visible = True
Application.ScreenUpdating = True
End Sub
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan