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 -