比较两个字符串并返回匹配的值？

Question

我希望比较两个相邻单元格中的两个字符串。 所有值以逗号分隔。 返回以逗号分隔的匹配值。

值有时会重复多次，并且可以位于字符串的不同部分。我列表中最大的字符串长度是 6264。

例如

Cell X2 = 219728401, 219728401, 219729021, 219734381, 219735301, 219739921

Cell Y2 = 229184121, 219728401, 219729021, 219734333, 216235302, 219735301

Result/Output = 219728401, 219729021, 219735301

我想应用它的单元格不仅限于 X2 和 Y2，它可以是 X 和 Y 列，输出到 Z 列（或我可以指定的列）。

感谢您对此提供的任何帮助，因为我对 Excel 的 VBA 知识有限。

谢谢。

Answer 1

如果您现在选择一系列行并运行宏 - 它会为根据 X 和 Y 列输入选择的每一行填充 Z 列。

Sub Macro1()
  ' https://stackoverflow.com/questions/54732564/compare-two-strings-and-return-matched-values
  Dim XString       As String
  Dim YString       As String
  Dim XArray()      As String
  Dim YArray()      As String
  Dim xe            As Variant
  Dim ye            As Variant
  Dim res           As Variant
  Dim ZString       As String
  Dim resCollection As New Collection
  Dim XColumnNumber As Long
  Dim YColumnNumber As Long
  Dim ZColumnNumber As Long
  Dim found         As Boolean
  XColumnNumber = Range("X1").Column
  YColumnNumber = Range("Y1").Column ' Could have done XColumn + 1 ! But if you want F and H it will work too now.
  ZColumnNumber = Range("Z1").Column ' Your result goes here
  Set resCollection = Nothing
  For Each r In Selection.Rows
    XString = ActiveSheet.Cells(r.Row, XColumnNumber).Value
    YString = ActiveSheet.Cells(r.Row, YColumnNumber).Value
    Debug.Print "XString: "; XString
    Debug.Print "YString: "; YString
    XArray = Split(XString, ",")
    YArray = Split(YString, ",")
    For Each xe In XArray
      Debug.Print "xe:"; xe
      For Each ye In YArray
        Debug.Print "ye:"; ye
        If Trim(xe) = Trim(ye) Then
          Debug.Print "Same trimmed"
          found = False
          For Each res In resCollection
            If res = Trim(xe) Then
                found = True
                Exit For
            End If
          Next res
          Debug.Print "Found: "; found
          If Not (found) Then
            resCollection.Add Trim(xe)
            Debug.Print "Adding: "; xe
          End If
        End If
      Next ye
    Next xe
    Debug.Print "resCollection: "; resCollection.Count
    ZString = ""
    For Each res In resCollection
        ZString = ZString & Trim(res) & ", "
    Next res
    If Len(ZString) > 2 Then
      ZString = Left(ZString, Len(ZString) - 2)
    End If
    ActiveSheet.Cells(r.Row, ZColumnNumber).Value = ZString
  Next r
End Sub

注意如果你有 2,1,2 和 2,5,2 并且想要 2,2 然后删除 if Not Found 部分并每次添加。

Answer 2

这是另一个使用 Dictionary 对象来评估匹配的版本。

它还使用数组来加快处理速度——对大型数据集很有用。

请务必按照代码的 cmets 中的说明设置引用，但如果您要分发此代码，您可能更喜欢使用后期绑定。

一个假设是您的所有值都是数字。如果有些包含文本，您可能（或可能不）想要将字典比较模式更改为文本。

Option Explicit
'Set reference to Microsoft Scripting Runtime

Sub MatchUp()
    Dim WS As Worksheet, R As Range
    Dim V, W, X, Y, Z
    Dim D As Dictionary
    Dim I As Long

Set WS = Worksheets("sheet1") 'Change to your desired worksheet
With WS
    'Change `A` to `X` for your stated setup
    Set R = .Range(.Cells(1, "A"), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)

    'Read range into variant array
    V = R
End With

For I = 2 To UBound(V, 1)
    W = Split(V(I, 1), ",")
    X = Split(V(I, 2), ",")
    V(I, 3) = ""

    'Test and populate third column (in array) if there are matches
    'Will also eliminate any duplicate codes within the data columns
    Set D = New Dictionary
        For Each Y In W
            Y = Trim(Y) 'could be omitted if no leading/trailing spaces
            If Not D.Exists(Y) Then D.Add Y, Y
        Next Y
        For Each Z In X
            Z = Trim(Z)
            If D.Exists(Z) Then V(I, 3) = V(I, 3) & ", " & Z
        Next Z
    V(I, 3) = Mid(V(I, 3), 3)
Next I

R.EntireColumn.Clear
R.EntireColumn.NumberFormat = "@"
R.Value = V 'write the results back to the worksheet, including column 3
R.EntireColumn.AutoFit
End Sub