Finde ord i tekststreng

I Ark1 har jeg en liste med "søgeord" i A-kolonnen

 

A

1

Ida

2

Erik

3

Hans

4

Willy

5

Bente

6

Malene 

7

Erling

8

Kim

I Ark2 har jeg i A-kolonnen en række tekststrenge:

 

A

B
1

Ida så Erik le

 
2

Erik så Hans og Willy slås

 
3

Hans fik en is

 
4

Kim og Mads så Erling danse

 
5

Bente var lun på Willy

 
6

Malene kyssede både Erling og Erik

 
7

Erling slog Erik med en våd avis

 
8

Ida og Erik så en sø

 
10 Mikkel så Malene bar  
11 Hans og Malene går i byen med Bente og Willy  
12 Vakse Viggo vandt over Kim  

I B-kolonnen i Ark2 vil jeg nu gerne have indsat en liste over de søgeord, der forekommer i hver tekststreng

 

A

B
1

Ida så Erik le

Ida, Erik,
2

Erik så Hans og Willy slås

Erik, Hans, Willy,
3

Hans fik en is

Hans,
4

Kim og Mads så Erling danse

Erling, Kim
5

Bente var lun på Willy

Willy, Bente,
6

Malene kyssede både Erling og Erik

Erik, Malene, Erling,
7

Erling slog Erik med en våd avis

Erik, Erling,
8

Ida og Erik så en sø

Ida, Erik,
10 Mikkel så Malene bar Malene,
11 Hans og Malene går i byen med Bente og Willy Hans, Willy, Bente, Malene,
12 Vakse Viggo vandt over Kim Kim,

Dette kan løses med følgende makro:

Sub FindOrd()
    Dim varX As String
    Dim FindOrd As String
    Dim varY As String
    Dim var1 As String
    Application.ScreenUpdating = False
    var1 = Sheets(1).Range("$A$1").Address & ":" _
        & Sheets(1).Range("a65536").End(xlUp).Address
    FindOrd = ""
    For Each c In Selection.Cells
        FindOrd = ""
        For Each x In Sheets(1).Range(var1).Cells
            varX = InStr(1, c.Value, x.Value)
            If varX <> 0 Then
                varY = InStr(varX, c.Value, " ")
                If varY = 0 Then
                    FindOrd = FindOrd & Mid(c.Value, varX, Len(c.Value)) & ", "
                Else
                    FindOrd = FindOrd & Mid(c.Value, varX, varY - varX) & ", "
                End If
            End If
        Next x
        c.Offset(0, 1).Value = FindOrd
    Next c
    Application.ScreenUpdating = True

End Sub

Marker tekststrengene i Ark2 og afspil makroen.

Det er også muligt at have søgeordene i én projektmappe (her Book1.xls) og tekststrengene i en anden (her Book2.xls). I så fald skal koden se således ud og begge projektmapper skal være åbne, når koden afspilles.

Sub FindOrdIFlereMapper()
    Dim varX As String
    Dim FindOrd As String
    Dim varY As String
    Dim var1 As String
    Application.ScreenUpdating = False
    var1 = Workbooks("book1.xls").Sheets(1).Range("$A$1").Address & ":" _
        & Workbooks("book1.xls").Sheets(1).Range("a65536").End(xlUp).Address
    FindOrd = ""
    For Each c In Selection.Cells
        FindOrd = ""
        For Each x In Workbooks("Book1.xls").Sheets(1).Range(var1).Cells
            varX = InStr(1, c.Value, x.Value)
            If varX <> 0 Then
            varY = InStr(varX, c.Value, " ")
                If varY = 0 Then
                    FindOrd = FindOrd & Mid(c.Value, varX, Len(c.Value)) & ", "
                Else
                    FindOrd = FindOrd & Mid(c.Value, varX, varY - varX) & ", "
                End If
            End If
        Next x
        c.Offset(0, 1).Value = FindOrd
     Next c
    Application.ScreenUpdating = True
End Sub

- Tilbage til makroer -
- Tilbage til Excel -