Question

数据位于一个名为Sheet1的Excel工作表中，A列具有人员ID。该ID可能是唯一的，尽管有时会重复2至5次。在每种情况下，我都想为每个ID设置一个范围（或数组），包括以下B，C，D和E列中的单元格。我要检查其名称中的重复项（B）位置（C）资历（D）在每个设定范围（或数组）内的数据来源（E-对于每个位置都是唯一的）。这将告诉我此人是否更改了职位，姓名或资历，因为该列表有2个列表（2018年列表和2019年列表）和每个列表3个子类别（部门B，C，D）。例如，在B部门中仍继续在同一职位上工作的人将有两行具有相同的数据，但E列除外，该列将在第1行显示“ 2018 List B”，在“ 2019 list B”中显示在第2行中突出显示重复内容是A和B列的第一件事，因为这在视觉上有所帮助，并且更容易找到在职员工。现在，我有一个串联的方法，因为所有数据都需要显示，并且不应删除。因此，当所有前面的列完全相同时，将串联E列。这样会将数据切成两半，我只需要查看E列中较小的文本字符串，以查看阻止合并的原因，这可能是1或更多列中的不匹配。例如。姓名变更，职位变更或资历变更。但是，我仍然无法跟踪阻止某些重复项合并的原因，因为随着职位的变更，合并变得更加复杂，因为该员工可能拥有多个职位，并且可能会增加或减少职位。同样，雇员可能是新员工，也可能不回来，这是由列E基于“ 2018”和“ 2019”数据确定的。

希望以下内容对将来的人有所帮助。为了使以下代码正常工作，必须对表进行排序，以使每行都在表的正下方，并且尽可能接近。


    Sub ConcatenateData()

    With Worksheets("Sheet1")
        With .Cells(2, "A").CurrentRegion
            .Cells.Sort Key1:=.Range("A3"), Order1:=xlAscending, _
                        Key2:=.Range("C3"), Order2:=xlAscending, _
                        Key3:=.Range("D3"), Order3:=xlAscending, _
                        Orientation:=xlTopToBottom, Header:=xlYes
        End With
    End With

    Dim my Rng As Range
    Dim prevRow As Range, myRow As Range
    Dim comparePrev As Range, comp As Range
    Dim prevData As Range, myData As Range
    Dim myIndex As Integer, numColumns As Integer

    Set myRng = ActiveCell.CurrentRegion
    numColumns = myRng.Columns.Count
    Set prevRow = myRng.Rows(1)
    myIndex = 2

    Do While myIndex <= myRng.Rows.Count
        Set myRow = myRng.Rows(myIndex)

        'Get all the cells from myRow except the last one
        Set comp = myRow.Resize(1, numColumns - 1)
        Set comparePrev = prevRow.Resize(1, numColumns - 1)

        If SameRanges(comp, comparePrev) Then

            'If  myData is the last cell from myRow
            Set myData = myRow.Cells(numColumns) 'Set myData = myRow.Offset(0, numColumns - 1).Resize(1, 1)
            Set prevData = prevRow.Cells(numColumns) 'Set prevData = prevRow.Offset(0, numColumns - 1).Resize(1, 1)

            ‘Group myData and delete myRow
            prevData.Value = prevData.Value & ", " & myData.Value
            myRow.Delete
        Else
            Set prevRow = myRow
            myIndex = myIndex + 1
        End If
    Loop


End Sub



'To compare ranges



Function SameRanges(range1 As Range, range2 As Range) As Boolean
'Return true if both ranges are the same

    Dim myIndex As Integer
    Dim cell1 As Range
    Dim cell2 As Range

    If range1.Cells.Count <> range2.Cells.Count Then
        SameRanges = False
        Exit Function
    End If

    For myIndex = 1 To range1.Cells.Count
        Set cell1 = range1.Cells(myIndex)
        Set cell2 = range2.Cells(myIndex)
        If cell1.Text <> cell2.Text Then
            SameRanges = False
            Exit Function
        End If
    Next
    SameRanges = True
End Function

``````````````

在ID重复的行上设置动态范围（或数组），并突出显示每个范围内多个条件上的唯一值

0 个答案: