Geavanceerd filteren in excel 2003

[mixomaxy]

Mijn vraag is als volgt:

Ik heb een enkele zeer grote tabellen meet daarin steeds terugkerende teksten.
Alle tekst staat in kolom A. Nu wil ik graag automatisch alle tekst tussen (variabel aantal cellen) die steeds terugkerende teksten
eruit filteren en opslaan. Mijn eerste idee was om er een ID-nr voor te zetten met een scheidingsteken
en dan te zoeken op begin- en eindtekst. Hiervan de ID nummer eruit tehalen en dan weet ik welke rijnummers
mij interesseren. Hoe kan ik nu de teksten ophalen van de desbetreffende rijnummers?

vb:

Kolom A
1 peer
2 bal
3 konijn
4 hond
5 kat
6 honing
7 merel
8 bal
9 schoen
10 boom
11 vijver
12 kat
13 pen
14 kaas
15 schoen
16 beer
17 bal
...


Resultaat:

Kolom B
1 konijn hond
2 schoen boom vijver
3 ...
4
...

Stel dat ik de resultaten tussen 'bal' en 'kat' er wil tussenuit filteren en deze teksten telkens wil samenvoegen in 1 cel.
Hoe kan ik dit doen?

mvg,

Kris Vermeulen

 

[HSV]

Je kan 'bal' en of 'kat' natuurlijk ook in een cel zetten en de code aanpassen.

Sub HSV()
 Range("D1").ClearContents
   Dim i As Long, j As Long
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
     For j = 1 To Cells(Rows.Count, 1).End(xlUp).Row - 1
       If LCase(Cells(i, 1).Offset(j)) = "bal" Or LCase(Cells(i, 1).Offset(j)) = "kat" Then Exit For
        If LCase(Cells(i, 1)) = "bal" And LCase(Cells(i, 1).Offset(j)) <> "kat" Then
         If Cells(i, 1).Offset(j) = "" Then Exit For
    If Cells(1, 4) = "" Then
        Cells(1, 4) = Cells(i, 1).Offset(j)
      Else
        Cells(1, 4) = Cells(1, 4) & "; " & Cells(i, 1).Offset(j)
    End If
   End If
  Next j
 Next i
End Sub

 

[mixomaxy]

Zeer bedankt!
Is het mogelijk om de gevonden resultaten (resultaat tussen 'bal' en 'kat' samen in 1 cel) telkens onder elkaar te plaatsen in een nieuwe cel?
vb.
Kolom
1 konijn; hond;
2 schoen; boom; vijver;
3 ...
4
5

 

[HSV]

Sub HSV()
 Range("D1").CurrentRegion.ClearContents
   Dim i As Long, j As Long, y As Long
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
     For j = 1 To Cells(Rows.Count, 1).End(xlUp).Row - 1
       If LCase(Cells(i, 1).Offset(j)) = "bal" Or LCase(Cells(i, 1).Offset(j)) = "kat" Then Exit For
        If LCase(Cells(i, 1)) = "bal" And LCase(Cells(i, 1).Offset(j)) <> "kat" Then
          If Cells(i, 1).Offset(j) = "" Then Exit For
        Cells(i, 4) = Cells(i, 4) & " " & Cells(i, 1).Offset(j)
      End If
     Next j
    Next i
  Range("D1:D" & Cells(Rows.Count, 4).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).Delete
 Columns(4).AutoFit
End Sub

Of met punt komma:

Sub HSV()
 Range("D1").CurrentRegion.ClearContents
   Dim i As Long, j As Long, y As Long
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
     For j = 1 To Cells(Rows.Count, 1).End(xlUp).Row - 1
       If LCase(Cells(i, 1).Offset(j)) = "bal" Or LCase(Cells(i, 1).Offset(j)) = "kat" Then Exit For
        If LCase(Cells(i, 1)) = "bal" And LCase(Cells(i, 1).Offset(j)) <> "kat" Then
          If Cells(i, 1).Offset(j) = "" Then Exit For
           If Cells(i, 4) = "" Then
            Cells(i, 4) = Cells(i, 1).Offset(j)
          Else
           Cells(i, 4) = Cells(i, 4) & "; " & Cells(i, 1).Offset(j)
        End If
      End If
     Next j
    Next i
  Range("D1:D" & Cells(Rows.Count, 4).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).Delete
 Columns(4).AutoFit
End Sub

 

[mixomaxy]

Harry,

Erg bedankt voor de hulp! Het script werkt super.
Dit spaart me vele avonden werk uit.

merci