Find tekststreng i tekst i celle i VBA

Range - Ark ?

Range A1
Ark1

den kommer til at være en del af en For Next, der læser gennem række 1 til End i kolonne 1.

Alle celler i kolonne 1 indeholdende -11 (en del af indholdet af cellen) skal beholdes, de øvrige skal slettes.

OK - vender tilbage senere..

PS: kunne du ikke fremstille en lille model, der viser før & efter?

Eksemplet er:

Indhold af ark1:

Celle    Indhold
A1      4100-10
A2      Overskrift - Medarbejder
A3      Hans
A4      Jan
A5      Peter

A8      4100-11
A9      Overskrift - Medarbejder
A10      Hans

A13      4101-10
A14      Overskrift - Medarbejder
A15      Peter
A16      Mogens


Jeg planlægger at anvende noget i stil med:

For I = 1 To DataSlutRække
    If Mid(Range("A" & I),Find("-";Range("A" & I),1)+1, 2) <> 11 Then
        StartRække = I
       
- Find næste tomme celle i kolonne 1 og sæt denne til SlutRække
- Slet Række I til Slutrække + 1
   
Next

Efterfølgende skulle det gerne se således ud:

Celle    Indhold
A1      4100-11
A2      Overskrift - Medarbejder
A3      Hans

Skal lige tilføje, at der kan forekomme numre der slutter på et bogstav eksempelvis 4200-11a

I eksemplet skal 4200-11a også blive stående, da funktionen alene skal se på de to tal der står efter "-".

Hej Supertekst

Jeg er kommet frem til følgende, men den sletter for meget (sletter alt hvor der ikke er en "-" i cellen, men ikke dem hvor der står et andet tal end 11 efter "-"?

'Slet alle data der ikke vedrører det valgte regnskabsår
For I = 1 To DataEndRow
    If Mid(Range("A" & I), InStr(1, Range("A" & I), "-") + 1, 2) <> 11 Then
        StartSletRow = I
            For S = I To I + 25
                If Range("A" & S).Value = "" Then
                    SlutSletRow = S + 2
                    Exit For
                End If
            Next
        Rows(StartSletRow & ":" & SlutSletRow).Delete
    End If
Next

Nu ser den således ud, men den fejler :-(

Sub test()

DataEndRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Offset(1, 0).Row - 1


'Slet alle data der ikke vedrører det valgte regnskabsår
For I = 1 To DataEndRow
   
'Find StartSletRow
    If Mid(Range("A" & I).Value, 1, 2) >= 0 And Mid(Range("A" & I).Value, 1, 2) <= 99 Then
        If Mid(Range("A" & I).Value, InStr(1, Range("A" & I).Value, "-") + 1, 2) <> 11 Then
            StartSletRow = I
            Debug.Print "Start " & StartSletRow
        End If
       
'Find SlutSletRow
        For S = StartSletRow To StartSletRow + 25
            If Range("A" & S).Value = "" Then
                SlutSletRow = S + 2
                Exit For
            End If
        Next

'Slet rækker fra StartSletRow til SlutSletRow
        Rows(StartSletRow & ":" & SlutSletRow).Delete
        I = 1
    End If

Next

End Sub

Er på igen - hvor fejles der?

Tror det hjælper hvis følgende tilføjes:

Sub test()

DataEndRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Offset(1, 0).Row - 1


'Slet alle data der ikke vedrører det valgte regnskabsår
For I = 1 To DataEndRow
   
'Find StartSletRow
    If Mid(Range("A" & I).Value, 1, 2) >= 0 And Mid(Range("A" & I).Value, 1, 2) <= 99 Then
        If Mid(Range("A" & I).Value, InStr(1, Range("A" & I).Value, "-") + 1, 2) <> 11 Then
            StartSletRow = I
            Debug.Print "Start " & StartSletRow
        End If
       
'Find SlutSletRow
        For S = StartSletRow To StartSletRow + 25
            If Range("A" & S).Value = "" Then
                SlutSletRow = S + 2
                Exit For
            End If
        Next

'Slet rækker fra StartSletRow til SlutSletRow
        Rows(StartSletRow & ":" & SlutSletRow - 1).Delete '+ -1
        I = 1
    End If

Next

End Sub

Slet rækker fra StartSletRow til SlutSletRow
        Rows(StartSletRow & ":" & SlutSletRow - 1).Delete '<< + -1

Den sletter næsten det hele. Det ser ud til at den tager udgangspunkt i en forkert række et sted i koden???

Har prøvet med dit eksempel før og efter - jeg fik det ønskede resultat.

Prøv evt at sende dit eksempel - @-adresse under min profil.

Med Rows(StartSletRow & ":" & SlutSletRow - 1).Delete sletter den alle 4100, 4101 m.v. (overskrifterne).

Der er noget andet galt - jeg vender tilbage i morgen.

Ok -

Alternativ:

Dim sidsteRæk As Long, ræk As Long, værdi, stregPos As Byte, slutRæk As Long
Sub test2()
    sidsteRæk = ActiveCell.SpecialCells(xlLastCell).Row
   
    For ræk = 1 To sidsteRæk
        værdi = Range("A" & ræk)
        If værdi = "" Then
            Exit For
        Else
            If testÅrstal(værdi) = False Then
                slutRæk = findAfslutÅrstal(ræk)
                Rows(ræk & ":" & slutRæk).Select
                Selection.Delete
                sidsteRæk = sidsteRæk - (slutRæk - ræk) + 1
                ræk = ræk - 1
            Else
                ræk = findAfslutÅrstal(ræk)
            End If
        End If
    Next ræk
End Sub
Private Function testÅrstal(værdi)
    If IsNumeric(Left(værdi, 2)) = True Then
        stregPos = InStr(værdi, "-")
        If stregPos > 0 Then
            If Mid(værdi, stregPos + 1, 2) <> 11 Then
                testÅrstal = False
            Else
                testÅrstal = True
            End If
        End If
    End If
End Function
Private Function findAfslutÅrstal(ræk)
Dim r As Long
    For r = ræk To sidsteRæk
        If Range("A" & r) = "" Then
            findAfslutÅrstal = r + 1
            Exit Function
        End If
    Next r
   
    findAfslutÅrstal = sidsteRæk
End Function

Tak Supertekst! Din løsning virker perfekt - lægger du et svar?

Løsningen blev:
Dim sidsteRæk As Long, ræk As Long, værdi, stregPos As Byte, slutRæk As Long
Sub testX()
    sidsteRæk = ActiveCell.SpecialCells(xlLastCell).Row
   
    Application.ScreenUpdating = False
   
    For ræk = 1 To sidsteRæk
        værdi = Range("A" & ræk)
        If værdi = "" Then
            Exit For
        Else
            If testÅrstal(værdi) = False Then
                slutRæk = findAfslutÅrstal(ræk)
                Rows(ræk & ":" & slutRæk).Select
                Selection.Delete
                sidsteRæk = sidsteRæk - (slutRæk - ræk) + 1
                ræk = ræk - 1
            Else
                ræk = findAfslutÅrstal(ræk)
            End If
        End If
    Next ræk
   
    Application.ScreenUpdating = True
End Sub
Private Function testÅrstal(værdi)
    If IsNumeric(Left(værdi, 2)) = True Then
        stregPos = InStr(værdi, "-")
        If stregPos > 0 Then
            If Mid(værdi, stregPos + 1, 2) <> 11 Then
                testÅrstal = False
            Else
                testÅrstal = True
            End If
        End If
    End If
End Function
Private Function findAfslutÅrstal(ræk)
Dim r As Long
    For r = ræk To sidsteRæk
        If Range("A" & r) = "" Then
            findAfslutÅrstal = r + 2
            Exit Function
        End If
    Next r
   
    findAfslutÅrstal = sidsteRæk
End Function

Et svar..

læser med...