Извлечение запятой отделяет несколько значений из диапазона ячеек

Question

Я пытаюсь вывести набор значений (набор из 3 или 4 значений) для поиска в строке данных с уникальными значениями в каждой ячейке, и, если какое-либо из этих значений совпадает, извлеките их, чтобы указать целевую запятую из одной ячейки. отделяется при необходимости. Любая помощь для достижения этого будет принята с благодарностью. Благодарю. Здесь сложная часть, значения для поиска представляют запятую, разделенную в одной ячейке.

Answer 1

Несмотря на то, что я отвечаю на мой вопрос, коды ниже предложены соответствующими разработчиками. Если вы решите использовать какой-либо из кодов, вам может потребоваться упорядочить код в соответствии с положением ваших данных на листе.

1) Это решение предложено Риком Ротштейном из MrExcel:

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) Вот еще один альтернативный код (спасибо Терри Х):

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) Еще один подход с помощью кнопок (спасибо 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