La extracción de comas separó varios valores de un rango de celdas

Question

Estoy tratando de buscar un conjunto de valores (ya sea un conjunto de 3 o 4 valores) en una fila de datos con valores únicos en cada celda y, si alguno o todos los valores coinciden, extraerlos para apuntar a una coma de celda única. separados si es necesario. Se agradecería cualquier ayuda para lograrlo. Gracias. Aquí la parte complicada, los valores a buscar están presentes separados por comas en una sola celda.

Answer 1

Aunque respondo mi pregunta, los códigos a continuación son sugeridos por los respectivos desarrolladores. Si decide utilizar cualquiera de los códigos, es posible que deba organizar el código de acuerdo con la posición de sus datos en la hoja.

1) Rick Rothstein de MrExcel sugiere esta solución:

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) Aquí hay otro código alternativo (Gracias a 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) Un acercamiento mutuo con botones (Gracias a 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