Excel VBA代码在列中查找重复项并从其他列中添加相应的值

Question

我希望有人能够帮助我解决这个问题。我有一个带有员工ID的专栏A，他们的工作时间在另一个专栏K中。有一些员工ID在列表中出现多次，我想知道在Excel VBA中是否有一种方法可以检查如果每个工作人员ID出现多次，并且如果是这样，则将他们的总工作时间加起来，并将结果放在与该工作人员ID的第一实例对应的另一列中，并且重复为0.

这是对于月度报告，任何时候都可能有超过2k条记录。

任何帮助将不胜感激。

在此先感谢

PS - 我只是一个中间当它涉及到VBA。

Answer 1

正如其他人所说，数据透视表确实是最好的方法。如果您不确定如何使用数据透视表或其优点，请致电refer to this SO post where I explain in detail。

无论如何，我将下面的VBA函数放在一起，以帮助您入门。这绝不是最有效的方法;这也使得以下假设：

• Sheet 1有
• A有工作人员用ID
• B有时间
• C保留用于总学时中的所有数据
• D将可处理状态输出

这当然可以通过修改代码很容易地改变。审查代码，它的评论让你明白。

Status列必须存在的原因是为了避免处理已经处理的Staff Id。你可以改变代码以避免需要这个列，但这是我处理事情的方式。

CODE

Public Sub HoursForEmployeeById() 

    Dim currentStaffId As String 
    Dim totalHours As Double 

    Dim totalStaffRows As Integer 
    Dim currentStaffRow As Integer 
    Dim totalSearchRows As Integer 
    Dim currentSearchRow As Integer 

    Dim staffColumn As Integer 
    Dim hoursColumn As Integer 
    Dim totalHoursColumn As Integer 
    Dim statusColumn As Integer 

    'change these to appropriate columns 
    staffColumn = 1 
    hoursColumn = 2 
    totalHoursColumn = 3 
    statusColumn = 4 

    Application.Calculation = xlCalculationManual 
    Application.ScreenUpdating = False 
    totalStaffRows = Sheet1.Cells(Rows.Count, staffColumn).End(xlUp).Row 
    For currentStaffRow = 2 To totalStaffRows 
     currentStaffId = Cells(currentStaffRow, staffColumn).Value 

     'if the current staff Id was not already processed (duplicate record) 
     If Not StrComp("Duplicate", Cells(currentStaffRow, statusColumn).Value, vbTextCompare) = 0 Then 
      'get this rows total hours 
      totalHours = CDbl(Cells(currentStaffRow, hoursColumn).Value) 
      'search all subsequent rows for duplicates 
      totalSearchRows = totalStaffRows - currentStaffRow + 1 
      For currentSearchRow = currentStaffRow + 1 To totalSearchRows 
       If StrComp(currentStaffId, Cells(currentSearchRow, staffColumn), vbTextCompare) = 0 Then 
        'duplicate found: log the hours worked, set them to 0, then mark as Duplicate 
        totalHours = totalHours + CDbl(Cells(currentSearchRow, hoursColumn).Value) 
        Cells(currentSearchRow, hoursColumn).Value = 0 
        Cells(currentSearchRow, statusColumn).Value = "Duplicate" 
       End If 
      Next 
      'output total hours worked and mark as Processed 
      Cells(currentStaffRow, totalHoursColumn).Value = totalHours 
      Cells(currentStaffRow, statusColumn).Value = "Processed" 
      totalHours = 0 'reset total hours worked 
     End If 
    Next 
    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationAutomatic 

End Sub 

BEFORE

AFTER

Answer 2

以下是位于范围A1：B10中的数据表的解决方案，其中标题和结果写入C列。

Sub Solution() 

Range("c2:c10").Clear 

Dim i 
For i = 2 To 10 

    If WorksheetFunction.SumIf(Range("A1:a10"), Cells(i, 1), Range("C1:C10")) = 0 Then 

     Cells(i, "c") = WorksheetFunction.SumIf(_ 
         Range("A1:a10"), Cells(i, 1), Range("B1:B10")) 
    Else 
     Cells(i, "c") = 0 
    End If 
Next i 

End Sub 

Answer 3

试试下面的代码：

Sub sample() 

    Dim lastRow As Integer, num As Integer, i As Integer 
    lastRow = Range("A65000").End(xlUp).Row 


    For i = 2 To lastRow 
     num = WorksheetFunction.Match(Cells(i, 1), Range("A1:A" & lastRow), 0) 

     If i = num Then 
      Cells(i, 3) = WorksheetFunction.SumIf(Range("A1:A" & lastRow), Cells(i, 1), Range("B1:B" & lastRow)) 
     Else 
      Cells(i, 1).Interior.Color = vbYellow 
     End If 
    Next 

End Sub 

前

后

Answer 4

Sub SelectColoredCells() 
    Dim rCell As Range 
    Dim lColor As Long 
    Dim rColored As Range 

    'Select the color by name (8 possible) 
    'vbBlack, vbBlue, vbGreen, vbCyan, 
    'vbRed, vbMagenta, vbYellow, vbWhite 
    lColor = RGB(156, 0, 6) 

    'If you prefer, you can use the RGB function 
    'to specify a color 
    'Default was lColor = vbBlue 
    'lColor = RGB(0, 0, 255) 

    Set rColored = Nothing 
    For Each rCell In Selection 
     If rCell.Interior.Color = lColor Then 
      If rColored Is Nothing Then 
       Set rColored = rCell 
      Else 
       Set rColored = Union(rColored, rCell) 
      End If 
     End If 
    Next 
    If rColored Is Nothing Then 
     MsgBox "No cells match the color" 
    Else 
     rColored.Select 
     MsgBox "Selected cells match the color:" & _ 
      vbCrLf & rColored.Address 
    End If 
    Set rCell = Nothing 
    Set rColored = Nothing 
End Sub 

此突出显示重复项目