vba - 使用 Excel VBA 查找列匹配并根据其他两列的值进行合并

Question

我在这里遇到了一个小难题，虽然网站上有一些建议，但没有什么完全适合我的要求。我需要根据行中某些单元格的值合并一些行。

我想我需要某种与名称匹配的代码，然后搜索具有相同名称的“New Starter”条目。

这是我的数据(类次、名称、详细信息)的外观:

09:00-17:00 Smith John      Present09:00-11:00 Smith John      New Starter11:10-13:00 Smith John      New Starter14:00-17:00 Smith John      New Starter09:00-17:00 Connor Sarah    Present09:00-11:00 Connor Sarah    New Starter11:10-13:00 Connor Sarah    New Starter14:00-17:00 Connor Sarah    New Starter09:00-17:00 Claus Santa     Present10:00-18:00 Mouse Mickey    Present10:00-11:00 Mouse Mickey    New Starter11:10-13:00 Mouse Mickey    New Starter14:00-18:00 Mouse Mickey    New Starter

我需要删除“新入门”行(如果存在)，但还要将其“当前”单元格替换为“新入门”(尽管如果需要，这可以是不同的文本):

09:00-17:00 Smith John      New Starter09:00-17:00 Connor Sarah    New Starter09:00-17:00 Claus Santa     Present10:00-18:00 Mouse Mickey    New Starter

您可以在此处看到圣诞老人不是新入门者，因此保持“在场”状态。

本质上，“新入门者”这句话是不需要的，但我确实想为新入门者提供与现有员工不同的细节。

附加说明:

• 如果存在“新启动器”，则“当前”行将始终存在。如果他们有“休息日”，那么就会有一个“休息日”行，我已经将其包含在其他要提取的子程序中。
• 要保留的数据是“当前”行中的任何内容，仅替换该标题(C 列)。

Answer 1

以下代码应该可以满足您的条件。已测试工作。

Sub RemoveDups()

Dim CurRow As Long, LastRow As Long, SrchRng As Range

LastRow = Range("A" & Rows.Count).End(xlUp).Row

    Range("A1:C" & LastRow).Select
    Sheets(1).Sort.SortFields.Clear
    Sheets(1).Sort.SortFields.Add Key:=Range("B2:B" & LastRow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Sheets(1).Sort.SortFields.Add Key:=Range("C2:C" & LastRow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets(1).Sort
        .SetRange Range("A1:C" & LastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

For CurRow = LastRow To 2 Step -1
    If Range("C" & CurRow).Value = "Present" Then
        If CurRow <> 2 Then
            If Not Range("B2:B" & CurRow - 1).Find(Range("B" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) is Nothing Then
                Range("C" & CurRow).Value = "New Starter"
            End If
        End If
    ElseIf Range("C" & CurRow).Value = "New Starter" Then
        Range("C" & CurRow).EntireRow.Delete xlShiftUp
    End If
Next CurRow

End Sub