Skjule rækker...

Her er en test kode

I arkets modul, koden under CheckBox1

Private Sub CheckBox1_Click()
Dim Tjek As Boolean
Tjek = CheckBox1.Value

Application.ScreenUpdating = False
MyCell = ActiveCell.Address

If Tjek Then ' der er flueben i
rw = Range("A3").CurrentRegion.Rows.Count
For r = rw To 3 Step -1
If Range("B" & r).Value = "!" Then
Range("B" & r).EntireRow.Hidden = True
End If
Next
End If

If Not Tjek Then ' der er ikke flueben i
rw = Range("A3").CurrentRegion.Rows.Count
For r = rw To 3 Step -1
If Range("B" & r).Value = "!" Then
Range("B" & r).EntireRow.Hidden = False
End If
Next
End If
Range(MyCell).Select
Application.ScreenUpdating = True
End Sub

Hej Kabbak...

Med en mindre ændring, så virker det 100%!!

---
Sub Afkrydsningsfelt8()
Dim Tjek As Boolean
Tjek = ActiveSheet.Shapes("afkrydsningsfelt 8").ControlFormat.Value = 1

Application.ScreenUpdating = False
MyCell = ActiveCell.Address

If Tjek Then ' der er flueben i
rw = Range("A3").CurrentRegion.Rows.Count
For r = rw To 3 Step -1
If Range("B" & r).Value = "!" Then
Range("B" & r).EntireRow.Hidden = True
End If
Next
End If

If Not Tjek Then ' der er ikke flueben i
rw = Range("A3").CurrentRegion.Rows.Count
For r = rw To 3 Step -1
If Range("B" & r).Value = "!" Then
Range("B" & r).EntireRow.Hidden = False
End If
Next
End If
Range(MyCell).Select
Application.ScreenUpdating = True
End Sub


---

Tusind tak for hjælpen :)
Skriv et svar....

det var godt at du kunne bruge det ;-))

Meget interessant kode. Den vil jeg da tage til mig :O) Smart at man kan gemme rækker med en checkbox. Tak for info.

Tis. Kan ikke få det til at virke. Kabbak, den kode du har postet, kan den blot copy/pastes ind i en tom projektmappe? Har prøvet at oprette et afkrydsningsfelt (CheckBox1), og indsat koden i mellem Private Sub og End Sub. Der sker ikke noget når jeg klikke i afkrydsningsfeltet. Har prøvet at indtaste ! i B3 i Ark1. Når jeg indsætter din kode, kan jeg godt bruge checkboksen. Når jeg indsætter den modificerede kode fra PBChristensen, får jeg debug fejl. Hvad er det jeg overser?
Kunne rigtigt godt bruge denne funktion til nogle af mine Excel ark. Håber ikke jeg mænger mig :O)

Har du data i A kolonnen fra A3 af, det skal du have, det er der den tæller rækker

@kabbak: Yep, kan stadig ikke få det til at funke. Jeg må gøre noget galt, så lister lige mine handlinger ud fra din kode kabbak:

1.Opretter ny projektmappe og vælger Udvikler på Båndet.
2.Vælger Indsæt og Afkrydsningsfelt under ActiveX-objekter.
3.Opretter boksen i Ark1 og dobbeltklikker boksen indeholdende teksten CheckBox1.
4.Siden med programkode vises, med Private Sub CheckBox1_Click() og End Sub.
5.Jeg kopierer din kode i mellem Private Sub CheckBox1_Click() og End Sub, og indsætter i mellem Private Sub CheckBox1_Click() og End Sub.
6. Jeg slår Designtilstand fra.
7. Jeg indtaster tilfældig data i celle A3 i Ark1 og et ! i celle B3.
8. Jeg klikker på afkrydsningsfeltet i CheckBox1, og intet sker. Alt data forbliver i Ark1.

Kan se tjek er forskellig fra din kode og den PBChristensen poster. Hvad gør forskellen?

Hvad bestemmer hvor langt koden søger i arket/hvad stopper den?

Hvad er forskellen på Sub og Private Sub?

@PBChristensen: Hvis du ikke ønsker jeg poster i din tråd, må du lige sige til. Finder bare denne kode super interessant.

fhansen82 hent den her

http://gupl.dk/701216/

Super mange tak kabbak. Dit eksempel virker næsten som det skal. Hvis jeg sætter ! i alle celler fra B3:B25 og klikker i CheckBox, så mangler A24:A25 at blive skjult. Og hvis jeg fx fjerner alt i celleområde A11:B25 og klikker i CheckBox, så skjuler den ikke alle rækker med forekomster af !. Oplever du også dette?

Private Sub CheckBox1_Click()
Dim Tjek As Boolean, RW As Long, R As Long

Tjek = CheckBox1.Value

Application.ScreenUpdating = False
MyCell = ActiveCell.Address
RW = ActiveCell.SpecialCells(xlLastCell).Row

If Tjek Then ' der er flueben i
For R = RW To 3 Step -1
If Range("B" & R).Value = "!" Then
Range("B" & R).EntireRow.Hidden = True
End If
Next
End If

If Not Tjek Then ' der er ikke flueben i
For R = RW To 3 Step -1
If Range("B" & R).Value = "!" Then
Range("B" & R).EntireRow.Hidden = False
End If
Next
End If
Range(MyCell).Select
Application.ScreenUpdating = True
End Sub

wee, Så virker koden i dit eksempel. Så vil jeg lege videre med den :O) Tak kabbak.