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的名字 Anyidea或更好的解决方案解决这个问题并获得所有需要的数据？。

最好的问候

POLOS

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中的输出

Answer 2

也许这样的事情呢？

Sub Test()

Dim i As Long, myrow As Long, lastrow As Long
Dim sht1 As Worksheet, sht2 As Worksheet

Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")

lastrow = 1

For i = 1 To 7
    If Application.WorksheetFunction.CountIf(sht1.Range("A:A"), sht2.Range("F" & i).Value) = 0 Then
        If i = 1 Then
            lastrow = 1
        Else
            lastrow = sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row + 1
        End If

        sht1.Range("A" & lastrow).Value = sht2.Range("F" & i).Value
        sht1.Range("B" & lastrow).Value = sht2.Range("G" & i).Value
    Else
        sht1.Range("B" & sht1.Columns("A:A").Find(What:=sht2.Range("F" & i).Value).Row).Value = sht1.Range("B" & sht1.Columns("A:A").Find(What:=sht2.Range("F" & i).Value).Row).Value & "/" & sht2.Range("G" & i).Value
    End If
Next i

End Sub

数据冲突 - 重复值

2 个答案: