vba - 数据冲突 - 重复值

Question

我创建了一个宏，用另一张工作表中的特定数据填充缺失的数据，这些代码可以完美地从客户端的 Excel 复制粘贴数据并准备开始工作所需的数据，但唯一的问题如下

代码:

   With Worksheets("Feuil2") 
   ' reference "target" sheet (change "Target" to our actual target sheet name)
     With .Range("B1:B" & .Cells(.Rows.Count, 1).End(xlUp).Row) 'reference 
         its column B range from row 1 down to last not empty one
        If WorksheetFunction.CountBlank(.Cells) > 0 Then 
 ' if any blank cell in referenced range. this check to avoid error thrown by subsequent 
    statament
            .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=index(GDC!" & rng.Offset(, 1).Address(, , xlR1C1) & ",match(RC[-1],GDC!" & rng.Address(, , xlR1C1) & ",0))" 'fill blank cells with a lookup (well, sort of) formula
            .Value = .Value 'get rid of formulas and leave values only
            Cells.Select
        End If
    End With
End With

这段代码在匹配和填充数据方面工作得很好，但是当例如找到重复的值时，它只复制第一个值而不是第二个值

请参阅下图以更好地了解主要问题:

正如您在图片中看到的问题，在 A 列中，我可能有数据重复两次，例如这个值 P20845，在 F 列中，一个重复的名称为 Ghaith，另一个重复的名称为 Sirine，但正如您所见可以看到，A 列中也只有 Ghaith 的名字，没有 Sirine 的名字有什么想法或更好的解决方案来解决这个问题并获取所有需要的数据吗？ 。

最诚挚的问候

波洛斯

Answer 1

或者使用字典

Option Explicit

Public Sub AddValues()
    Application.ScreenUpdating = False
    Dim wb As Workbook, wsSource As Worksheet, wsTarget As Worksheet, masterDict As Object, arr() As Variant, i As Long, rng As Range
    Set wb = ThisWorkbook
    Set wsSource = wb.Worksheets("Feuil1")
    Set wsTarget = wb.Worksheets("Feuil2")
    Set masterDict = CreateObject("Scripting.Dictionary")

    With wsSource
        arr = Intersect(.Columns("A:B"), .UsedRange)
        For i = 1 To UBound(arr, 1)
            If Not masterDict.exists(arr(i, 1)) Then masterDict.Add arr(i, 1), GetAllMatches(arr(i, 1), arr(i, 2), wsSource)
        Next i
    End With

    With wsTarget
        For Each rng In Intersect(.Columns("A"), .UsedRange)
            On Error Resume Next
            rng.Offset(, 1) = masterDict(rng.Value)
            On Error GoTo 0
        Next rng       
    End With
    Application.ScreenUpdating = True
End Sub
Public Function GetAllMatches(ByVal findString As String, ByVal dupString As String, ByVal searchRng As Worksheet) As String

    Dim foundCell As Range
    Dim concatenatedString As String
    concatenatedString = vbNullString

    With Intersect(searchRng.Columns(1), searchRng.UsedRange)

        Set foundCell = .Find(findString)
        If foundCell Is Nothing Then Exit Function
        If Not foundCell Is Nothing Then concatenatedString = foundCell.Offset(, 1)

        Dim currMatch As Long
        currMatch = 0

        For currMatch = 1 To WorksheetFunction.CountIf(.Cells, findString)

            Set foundCell = .Find(What:=findString, After:=foundCell, _
                                  LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                                  SearchDirection:=xlNext, MatchCase:=False)

            If Not foundCell Is Nothing And InStr(1, dupString, concatenatedString) = 0 Then
                concatenatedString = concatenatedString & "/" & foundCell.Offset(, 1)
            Else
                concatenatedString = foundCell.Offset(, 1)
            End If
        Next currMatch
    End With
    GetAllMatches = concatenatedString
End Function

Feuil2 中的输出