Skjul rækker

Public Sub skjul()

    Dim X As Long, I As Long, RW As Long, Kolonne As String
    Application.ScreenUpdating = False
    Cells.EntireRow.Hidden = False
    Kolonne = "C"    ' ret C til den kolonne der skal tjekkes i
    RW = Range(Kolonne & "65536").End(xlUp).Row

    For X = RW To 1 Step -1
        For I = 42 To 64
            If Cells(X, Kolonne) = Chr(I) Then
                Cells(X, Kolonne).EntireRow.Hidden = True
                Exit For
            End If
        Next
    Next
   
    Application.ScreenUpdating = True
End Sub

prøv denne

Sub timesedler_hent_udfra_dato_ny_test()
    Dim RW As Long, Data1 As Variant
    Dim intI As Long, intJ As Long, Synlig As Boolean
    Dim Fra As Date, Til As Date
    Synlig = False
    If Application.DisplayStatusBar Then
        Synlig = True
    Else
        Synlig = False
        Application.DisplayStatusBar = True
    End If


    ThisWorkbook.Sheets("timesedler").Rows("4:65536").ClearContents' tømmer arket "timesedler"
    Fra = Sheets("stam").Range("timesedler_fradato")
    Til = Sheets("stam").Range("timesedler_tildato")

    Application.ScreenUpdating = False
    Application.Calculation = xlManual

    RW = ThisWorkbook.Worksheets("2008").Range("C65536").End(xlUp).Row
    Data1 = ThisWorkbook.Sheets("2008").Range("C1:C" & RW)

    For intI = 2 To UBound(Data1)
        If Data1(intI, 1) > Til Then Exit For
        If Data1(intI, 1) >= Fra And Data1(intI, 1) <= Til Then
            intJ = ThisWorkbook.Sheets("timesedler").Range("B65536").End(xlUp).Row + 1
            ThisWorkbook.Sheets("2008").Range("A" & intI & ":T" & intI).Copy ThisWorkbook.Sheets("timesedler").Range("A" & intJ)
        End If

        Application.StatusBar = " Kikker på række " & intI & " af " & RW & " heraf kopieret " & intJ - 3
    Next
    Application.StatusBar = ""
    MsgBox "Færdig"
    If Not Synlig Then Application.DisplayStatusBar = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub timesedler_hent_udfra_dato()
   
    Dim intI As Integer
    Dim intJ As Integer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
   
    Rows("5:5000").Select
    Selection.Delete Shift:=xlUp
    Range("a1").Select
   
    Set shtime = ThisWorkbook.Sheets("timesedler")
    Set sh2008 = ThisWorkbook.Sheets("2008")
'    Set shFak = ThisWorkbook.Sheets("faktura")
    Set shstam = ThisWorkbook.Sheets("stam")
   
    intJ = 5
    Do Until (ThisWorkbook.Sheets("timesedler").Cells.Range("B" & intJ) = "")
        intJ = intJ + 1
    Loop
   
    rk08 = sh2008.Cells(250000, "B").End(xlUp).Row
    revinit = shstam.Range("timesedler_init")
    x = Application.CountIf(sh2008.Range("D5:D" & rk08), revinit)
    RK = 4
 
    For intI = 5 To x
      rk1 = sh2008.Range("D" & RK & ":D250000").Find(revinit, LookIn:=xlValues, LookAt:=xlWhole).Row
      RK = rk1
     
    If sh2008.Cells.Range("C" & RK) >= shstam.Cells.Range("timesedler_fradato") And _
        sh2008.Cells.Range("C" & RK) <= shstam.Cells.Range("timesedler_tildato") Then
       
        sh2008.Range("A" & RK & ":T" & RK).Copy shtime.Range("A" & intJ)
       
        intJ = intJ + 1
        End If
        'Application.StatusBar = "Henter data fra " & x & " linjer!"
  Next
 
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
   
End Sub

der kom for meget med
Sub timesedler_hent_udfra_dato_ny_test()
    Dim RW As Long, Data1 As Variant
    Dim intI As Long, intJ As Long, Synlig As Boolean
    Dim Fra As Date, Til As Date
    Synlig = False
    If Application.DisplayStatusBar Then
        Synlig = True
    Else
        Synlig = False
        Application.DisplayStatusBar = True
    End If


    ThisWorkbook.Sheets("timesedler").Rows("4:65536").ClearContents
    Fra = Sheets("stam").Range("timesedler_fradato")
    Til = Sheets("stam").Range("timesedler_tildato")

    Application.ScreenUpdating = False
    Application.Calculation = xlManual

    RW = ThisWorkbook.Worksheets("2008").Range("C65536").End(xlUp).Row
    Data1 = ThisWorkbook.Sheets("2008").Range("C1:C" & RW)

    For intI = 2 To UBound(Data1)
        If Data1(intI, 1) > Til Then Exit For
        If Data1(intI, 1) >= Fra And Data1(intI, 1) <= Til Then
            intJ = ThisWorkbook.Sheets("timesedler").Range("B65536").End(xlUp).Row + 1
            ThisWorkbook.Sheets("2008").Range("A" & intI & ":T" & intI).Copy ThisWorkbook.Sheets("timesedler").Range("A" & intJ)
        End If

        Application.StatusBar = " Kikker på række " & intI & " af " & RW & " heraf kopieret " & intJ - 3
    Next
    Application.StatusBar = ""
    MsgBox "Færdig"
    If Not Synlig Then Application.DisplayStatusBar = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

NB den sidste række i arket Worksheets("2008"), skal være tom, altså række 65536

sorry, det sidste var forkert spørgsmål ;-))

Public Sub skjul()

    Dim X As Long, I As Long, RW As Long, Kolonne As String
    Application.ScreenUpdating = False
    Cells.EntireRow.Hidden = False
    Kolonne = "C"    ' ret C til den kolonne der skal tjekkes i
    RW = Range(Kolonne & "65536").End(xlUp).Row

    For X = RW To 1 Step -1
        For I = 42 To 64
            If Cells(X, Kolonne) = Chr(I) Then
                Cells(X, Kolonne).EntireRow.Hidden = True
                Exit For
            End If
        Next
    Next
 
    Application.ScreenUpdating = True
End Sub

Koden virker, men kan den modificeres så den skjuler rækkerne i et interval fra f.eks. celleværdi A til celleværdi B?

Koden skjuler alt omkring værdien I. Meningen er at hvis der i celle A3 står I og i celle A6 står R skal rækkerne i mellem skjules? De ovenstående skal ikke skjules og de nedenstående skal heller ikke skjules medmindre et nyt interval fra I til R fremkommer?

På forhånd tak!!

Nu er rettet til det du skriver 11/11-2008 21:50:15


Public Sub skjul()
    Dim X As Long, I As Long, RW As Long, Kolonne As String
    Dim GemRække As Boolean
    Application.ScreenUpdating = False
    Cells.EntireRow.Hidden = False
    Kolonne = "A"    ' ret C til den kolonne der skal tjekkes i
    RW = Range(Kolonne & "65536").End(xlUp).Row

    For X = RW To 1 Step -1
        If UCase(Cells(X, Kolonne)) = "I" Then GemRække = False
        If GemRække Then
            Cells(X, Kolonne).EntireRow.Hidden = True
        End If
        If UCase(Cells(X, Kolonne)) = "R" Then GemRække = True
    Next
    Application.ScreenUpdating = True
End Sub

Tusinde tak Kabbak. Det virker perfekt!