Skjule rækker VBA

Ups. Fjern ark beskyttelse før koden og beskyt ark og gem efter koden.

Det her vil skjule fra række 238 og frem indtil der kommer en celle i kolonne B med en værdi højere end 2.

Hvis der ikke findes nogen værdier i kolonne B, så tager det noget tid før den bliver færdig ;) Så hvis det er flere hundred tusind linier du skal have skjult er det måske ikke den mest optimale løsning :)


Sub Test()
  Application.ScreenUpdating = False
       
    If ActiveSheet.ProtectContents = True Then
        SheetProtected = True
        ActiveSheet.Unprotect
    Else
        SheetProtected = False
    End If
   
    Range("B238").Select
    Do Until ActiveCell.Value > 2
        ActiveCell.EntireRow.Hidden = True
        ActiveCell.Offset(1, 0).Select
    Loop
   
    Application.ScreenUpdating = True
   
    If SheetProtected = True Then
        ActiveSheet.Protect
    End If
End Sub

Må jeg foreslå dig at gå på udkig i http://www.kronsell.net/

Her ligger en række småmakroer som er tæt på det du leder efter. Jkrons mener jeg også selv deltager på disse sider indimellem.

Der kommer lige en optimering..

Sub Test()
  Application.ScreenUpdating = False
       
    If ActiveSheet.ProtectContents = True Then
        SheetProtected = True
        ActiveSheet.Unprotect
    Else
        SheetProtected = False
    End If
   
    Range("B238").Select
    Do Until ActiveCell.Value > 2
        ActiveCell.Offset(1, 0).Select
    Loop
    Range("B238:B" & ActiveCell.Row).EntireRow.Hidden = True
   
    Application.ScreenUpdating = True
   
    If SheetProtected = True Then
        ActiveSheet.Protect
    End If
End Sub

Hej IT-GuFFe, koden virker ikke, der kommer en box op med teksten fejl 400 og curseren stopper i B1048576.


Hej kim1a, tak for tippet

Prøv denne på en kopi:

Hej Boro23,
Når du skriver fra række 238 og op efter så forstår jeg at du vil skjule række 1 til 238. Derfor foreslår jeg følgende:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B:B")) Is Nothing Then
ActiveSheet.Unprotect
If Application.WorksheetFunction.Max(Range("B:B")) <= 2 Then
Range("B1:B238").EntireRow.Hidden = True
Else
Range("B1:B238").EntireRow.Hidden = False
End If
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End If
End Sub

Makroen aktiveres automatisk, hvis der skrives noget i kolonne B, som jeg antager ikke er låst.

Hvis jens48 har ret, har jeg denne rettelse:

Hej store-morten
jens48 har ret, din kode virker præsis som den skal. Igen 1000 tak, smider du et svar. Go' weekend


Hej jens48
Tak for dit indlæg, uden den var resultatet nok ikke blevet som det blev. Jeg har oprettet en tråd "point til jens48", vi du smide et svar der. Go' weekend

Velbekomme.