Extrahieren von durch Kommas getrennten Mehrfachwerten aus einem Zellbereich

Question

Ich versuche, einen Wertesatz (entweder einen Satz von 3 oder 4 Werten) in einer Datenzeile mit eindeutigen Werten in jeder Zelle nachzuschlagen und, wenn einige oder alle Werte übereinstimmen, diese bei Bedarf in eine einzelne Zielzelle mit Komma-Trennung zu extrahieren. Für jede Hilfe hierzu wäre ich dankbar. Danke. Hier kommt der schwierige Teil: Die nachzuschlagenden Werte liegen mit Komma-Trennung in einer einzelnen Zelle vor.

Answer 1

Obwohl ich meine Frage beantworte, werden die folgenden Codes von den jeweiligen Entwicklern vorgeschlagen. Wenn Sie sich entscheiden, einen der Codes zu verwenden, müssen Sie den Code möglicherweise entsprechend der Position Ihrer Daten im Blatt anordnen.

1) Diese Lösung wird von Rick Rothstein von MrExcel vorgeschlagen:

Sub GetValues()

 Dim R As Long, C As Long, V As Variant, Txt As String
  For C = 11 To Cells(1, Columns.Count).End(xlToLeft).Column
    For R = 3 To Cells(Rows.Count, "A").End(xlUp).Row
      Txt = ""
      For Each V In Split(Cells(1, C).Value, ",")
        If Not Intersect(Rows(R), Columns("A:I")).Find(V, , , xlWhole, , , False, `enter code here`False) Is Nothing Then Txt = Txt & "," & V
      Next
      Cells(R, C).Value = Mid(Txt, 2)
    Next
  Next
End Sub

2) Hier ist ein weiterer alternativer Code (Danke an Terry X):

Sub Test()

startCol = 11

EndCol = 13

'EndCol = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column

StartRow = 5

EndRow = 7

'EndRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

Dim arr As Variant

Dim dataRng As Range

For i = StartRow To EndRow

     Set dataRng = Range(Cells(i, 1), Cells(i, 8))

     dataRng.Select

     For j = startCol To EndCol

     valueToLookUP = Cells(1, j).Value

     arr = Split(valueToLookUP, ",")

     resultStr = ""

     For k = LBound(arr) To UBound(arr)

     On Error Resume Next

     idx = WorksheetFunction.Match(arr(k), dataRng, 0)

     If idx > 0 Then

     resultStr = resultStr + "," + arr(k)

     End If

     idx = 0

     Next k

     If Len(resultStr) > 0 Then resultStr = Mid(resultStr, 2)

     Cells(i, j).Value = resultStr

     Next j

Next i

End Sub

3) Ein weiterer Ansatz mit Schaltflächen (Danke an Ashidacchi):

Option Explicit

Private kw1, kw2, kw3, kw4 As String
Private match1, match2, match3, match4 As String
Private strTarget As String

' ---[Smart Search]
Private Sub btn_SmartSearch_Click()
    Dim firstRow As Integer: firstRow = 5
    Dim lastRow As Integer: lastRow = Range("A99999").End(xlUp).Row
    ' ---
    Dim myRow As Integer
    For myRow = firstRow To lastRow
        Call prc_Clear_Match_KW             ' -- clear match1~match4, kw1~kw4
        Call prc_Create_TargetString(myRow) ' -- create strTarget
        ' ---
        If (strTarget <> "") And (Range("K1").Value <> "") Then
            Dim commaCnt As Integer ' -- the number of comma(s) in cell [K1]
            Dim kwCnt As Integer    ' -- the number of keyword(s) in cell [K1]
            ' ---
            commaCnt = Len(Range("K1")) - Len(Replace(Range("K1"), ",", ""))
            kwCnt = commaCnt + 1
            Call prc_Set_Keyword(kwCnt)
            'MsgBox "kwCnt=" & kwCnt
            ' --- kw ‚ª‘¶Ý‚·‚ê‚Î match ‚É kw ‚ðƒZƒbƒg
            If (InStr(strTarget, kw1) > 0) Then
                match1 = kw1
            End If
            If (InStr(strTarget, kw2) > 0) Then
                match2 = kw2
            End If
            If (InStr(strTarget, kw3) > 0) Then
                match3 = kw3
            End If
            If (InStr(strTarget, kw4) > 0) Then
                match4 = kw4
            End If
            ' --- set matching result to column [K]
            Call prc_Set_Result(myRow)
        End If
    Next
    ' ---
    MsgBox "[Smart Search] completed !!)"
End Sub
' -- create strTarget: concatenate cells 1 - 8
Private Sub prc_Create_TargetString(ByVal myRow As Integer)
    strTarget _
        = Cells(myRow, 1).Value & Cells(myRow, 2).Value _
        & Cells(myRow, 3).Value & Cells(myRow, 4).Value _
        & Cells(myRow, 5).Value & Cells(myRow, 6).Value _
        & Cells(myRow, 7).Value & Cells(myRow, 8).Value
        '' --- for debugging
        ' MsgBox "strTarget=" & strTarget
End Sub
' ---
Private Sub prc_Set_Keyword(ByVal kwCnt As Integer)
    Select Case kwCnt
        Case Is = 1     ' -- one Keyword
            kw1 = Mid(Range("K1").Value, 1, 1)
        Case Is = 2     ' -- two Keywords
            kw1 = Mid(Range("K1").Value, 1, 1)
            kw2 = Mid(Range("K1").Value, 3, 1)
        Case Is = 3     ' -- three Keywords
            kw1 = Mid(Range("K1").Value, 1, 1)
            kw2 = Mid(Range("K1").Value, 3, 1)
            kw3 = Mid(Range("K1").Value, 5, 1)
        Case Is = 4     ' -- four Keywords
            kw1 = Mid(Range("K1").Value, 1, 1)
            kw2 = Mid(Range("K1").Value, 3, 1)
            kw3 = Mid(Range("K1").Value, 5, 1)
            kw4 = Mid(Range("K1").Value, 7, 1)
    End Select
    '' --- for debugging
'    MsgBox "kw1=" & kw1 & Chr(13) & _
'           "kw2=" & kw2 & Chr(13) & _
'           "kw3=" & kw3 & Chr(13) & _
'           "kw4=" & kw4
End Sub
' ---
Private Sub prc_Clear_Match_KW()
    match1 = ""
    match2 = ""
    match3 = ""
    match4 = ""
    ' --
    kw1 = ""
    kw2 = ""
    kw3 = ""
    kw4 = ""
End Sub
' ---
Private Sub prc_Set_Result(ByVal myRow As Integer)
    Dim strResult As String: strResult = ""
    If (match1 <> "") Then
        strResult = match1
    End If
    If (match2 <> "") Then
        strResult = strResult & "," & match2


End If
    If (match3 = "") Then
        strResult = strResult & "," & match3
    End If
    If (match4 = "") Then
        strResult = strResult & "," & match3
    End If
    ' ---
    Do Until Left(strResult, 1) <> ","
        strResult = Mid(strResult, 2, Len(strResult) - 1)
    Loop
    Do Until Right(strResult, 1) <> ","
        strResult = Mid(strResult, 1, Len(strResult) - 1)
    Loop
    ' ---
    Cells(myRow, 11).Value = strResult
End Sub
' ---[Clear Result]
Private Sub btn_ClearResult_Click()
    Range("K5:T50").Value = ""
End Sub