excel - 列内の重複を見つけて、別の列から対応する値を追加します

Question

スタッフIDと勤務時間が列Kにある列Aがあります。

スタッフ ID が複数回表示されて勤務時間を追加し、結果をそのスタッフ ID の最初のインスタンスに対応する別の列に入れ、重複が 0 の場合を希望します。

これは月次レポート用であり、任意の時点で 2,000 件を超えるレコードが存在する可能性があります。

Answer 1

他の誰もが言ったように、ピボット テーブルは本当に最善の方法です。ピボットテーブルの使用方法やその利点がわからない場合は、詳細を説明するこの SO 投稿を参照してください。

とにかく、私はあなたが始めるのを助けるために以下のVBA関数をまとめました. これは決して最も効率的なアプローチではありません。また、次の仮定も行います。

• Sheet 1すべてのデータを持っています
• AスタッフIDあり
• B営業時間あり
• C合計時間のために予約されています
• Dステータス出力の処理に使用できます

もちろん、これはコードを少し変更することで非常に簡単に変更できます。コードを確認してください。理解できるようにコメントが付けられています。

Status列が存在しなければならない理由は、Staff Id既に処理された a を処理しないようにするためです。このコラムが不要になるようにコードを大幅に変更することもできますが、これが私が行った方法です。

コード

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

前

後

Answer 2

以下のコードを試してください：

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 3

以下は、範囲 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 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

これにより、重複が強調表示されます