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

Question

我这里有一个小难题，虽然网站上有一些建议，但没有什么对我来说很合适。我需要根据行中某些单元格的值合并一些行。

我想我需要某种与名称匹配的代码，然后搜索具有相同名称的"新入门"条目。

以下是我的数据（移位、名称、详细信息）的外观：

09：00-17：00 史密斯·约翰出席09：00-11：00 史密斯·约翰 新首发11：10-13：00 史密斯·约翰 新首发14：00-17：00 史密斯·约翰 新首发09：00-17：00 康纳·莎拉出席09：00-11：00 康纳·莎拉 新开场白11：10-13：00 康纳·莎拉 新首发14：00-17：00 康纳·莎拉 新开场白09：00-17：00 圣诞老人礼物10：00-18：00 鼠标米奇礼物10：00-11：00 鼠标米奇新开胃菜11：10-13：00 鼠标米奇新开胃菜14：00-18：00 鼠标米奇新开胃菜

我需要删除新入门行（如果存在），但也将其"当前"单元格替换为"新入门"（尽管如果需要，这可以是不同的文本）：

09：00-17：00 史密斯·约翰 新首发09：00-17：00 康纳·莎拉 新开场白09：00-17：00 圣诞老人礼物10：00-18：00 鼠标米奇新开胃菜

你可以在这里看到圣诞老人不是新手，因此保持"礼物"。

从本质上讲，"新入门"系列是不需要的，但我确实想给新入门者一个与现有员工不同的细节。

附加说明：

• 如果存在"新启动器"，则"当前"行将始终存在。如果他们有"休息日"，那么只会有一个"休息日"行，我已经包含在其他Subs中提取
。
• 要保留的数据是"当前"行中的任何内容，仅替换该标题（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

Answer 2

您需要考虑的第二种方法，就数据位置而言，可能更"通用"和"可移植"。 如果要在合并之前对数据进行排序，则使用替代方法（更长期？ Range.Sort方法与 Excel 2003 兼容。 有关优化此方法的更多参数，请参阅此处的 msdn 参考

Option Explicit
Sub newStarters()
Dim ws As Worksheet
Dim dRng As Range
Dim stRow As Long, endRow As Long, nameCol As Long, c As Long
Dim nme As String, changeStr As String
'explicitly identify data sheet
Set ws = Sheets("Data")
'start row of data
stRow = 2
'column number of "Name"
nameCol = 3
'set changeStr
changeStr = "New Starter"
    'Use the explicit data sheet
    With ws
        'find last data row
        endRow = .Cells(Rows.Count, nameCol).End(xlUp).Row
        'if you want the data to be sorted before consolidating
        '======================================================
        'Set dRng = .Range(.Cells(stRow, nameCol).Offset(0, -1), _
        '            .Cells(endRow, nameCol).Offset(0, 1))
        'dRng.Sort Key1:=.Cells(stRow, nameCol), Order1:=xlAscending, _
        '          Key2:=.Cells(stRow, nameCol).Offset(0, 1), Order2:=xlDescending, _
        '          Header:=xlNo
        '======================================================
            'consolidate data
            For c = endRow To stRow Step -1
                With .Cells(c, nameCol)
                    nme = .Value
                        If .Offset(0, 1).Value = changeStr Then
                            If .Offset(-1, 0).Value = nme Then
                                .Offset(-1, 1).Value = changeStr
                                .EntireRow.Delete xlShiftUp
                            End If
                        End If
                End With
            Next c
    End With
End Sub