VBA Excel Identify repeated values in different columns and transpose values

Question

I want to identify when a person in Column2 has multiple entries on the same day (Column1) - up to 6 entries per person per day. Then I condense them into 1 row on a subsequent sheet and transpose the data in Column3. The data is sorted by Date in Column1 then alphabetically in Column2.

I have some code that I don't want to post b/c I think that I've chosen a bad strategy with a Do..Until loop while indexing the Row number. I need a different strategy. I also have ~10,000 rows, so VBA is necessary and efficiency is appreciated... our lab only has 32-bit excel :P

Data

Employee    Date Worked Hours   Activity
Carl    7/1/2017    0.5 A
Greg    7/1/2017    1   A
Greg    7/1/2017    0   B
Greg    7/1/2017    12.25   C
Howard  7/1/2017    0.5 B
Howard  7/1/2017    0.5 E
Howard  7/1/2017    0   D
Howard  7/1/2017    6   F
Howard  7/1/2017    6.5 G
Kevin   7/1/2017    1   A
Kevin   7/1/2017    0   B
Kevin   7/1/2017    12.5    C
Mario   7/1/2017    0.25    C
Mario   7/1/2017    0.25    E
Mario   7/1/2017    0   F
Mario   7/1/2017    0.5 G
Mario   7/1/2017    24  H
Carl    7/2/2017    0.5 A
Greg    7/2/2017    1   B
Greg    7/2/2017    0   C
Greg    7/2/2017    12.25   D
Howard  7/2/2017    0.5 B
Howard  7/2/2017    0.5 C
Howard  7/2/2017    0   D
Howard  7/2/2017    2   E
Howard  7/2/2017    10.5    F
Kevin   7/2/2017    1   A
Mario   7/2/2017    0.25    C
Mario   7/2/2017    0.25    E
Mario   7/2/2017    0   F
Mario   7/2/2017    0.5 G
Mario   7/2/2017    24  H
Ted 7/2/2017    1   C
Kay 7/2/2017    1   A

WorkbookDataAndResult

It's better to post code with bad strategy instead of none :) — ashleedawg, May 05 '18 at 13:58
There all kind of free (and paid) plugins to do this for you. Google "duplicate removal excel". — Roemer, May 05 '18 at 14:19
@Roemer, I have other columns of task and hours I need to classify by task and summarize hours. — B Real, May 05 '18 at 16:39
Why not just use a Pivot Table. The output might be a bit different, but still simple, fast and usable. — Ron Rosenfeld, May 05 '18 at 19:24

score 0 · Answer 1 · answered May 06 '18 at 20:11

I made it work... I had a problem with syntax, I forgot that VBA doesn't like random carriage returns mid-program.  Thank you all!

Sub ShiftMini2()
'CRow is Current Row
'LastRow is Last Row
'Columns
    Dim QCRow As Long
    Dim QLastRow As Long
    Dim QnxtRow As Long
    Dim ShiftCnt As Integer
'On Error GoTo Errorcatch
'LastRow = Cells(Rows.Count, "A").End(xlUp).Row
QCRow = 2
QLastRow = 35  '18556
QnxtRow = 1

'Label Columns
Sheets(2).Cells(1, 12).Value = "SSP"
Sheets(2).Cells(1, 13).Value = "BC"
Sheets(2).Cells(1, 14).Value = "Beeper Hours 1"
Sheets(2).Cells(1, 15).Value = "Beeper Hours 2"
Sheets(2).Cells(1, 16).Value = "House Hours 1"
Sheets(2).Cells(1, 17).Value = "House Hours 2"
Sheets(2).Cells(1, 18).Value = "Shift1"
Sheets(2).Cells(1, 19).Value = "Shift2"
Sheets(2).Cells(1, 20).Value = "Shift3"
Sheets(2).Cells(1, 21).Value = "Shift4"
Sheets(2).Cells(1, 22).Value = "Shift5"

'If New Dsy OR New Person Then copy row.
'Else Same Person or Same Day

Do Until QCRow = 35
    QCol = 18
    ShiftCnt = 0 'Reset ShiftCnt for each new QnxtRow
    If Sheets(1).Cells(QCRow, 2) <> Sheets(1).Cells(QCRow - 1, 2) Or Sheets(1).Cells(QCRow, 1) <> Sheets(1).Cells(QCRow - 1, 1) Then
        Sheets(1).Select
        Rows(QCRow).Copy
        QnxtRow = QnxtRow + 1   'Sheets(2).Select
        Sheets(2).Select
        Cells(QnxtRow, 1).Select
        ActiveSheet.Paste
        Sheets(2).Cells(QnxtRow, QCol).Value = Sheets(1).Cells(QCRow, 4).Value
        Dim Stringer1 As String
                Stringer1 = Sheets(1).Cells(QCRow, 4).Value
                If InStr(1, Stringer1, "SSP") <> 0 Then Sheets(2).Cells(QnxtRow, 12).Value = 1
                If InStr(1, Stringer1, "BC") <> 0 Then Sheets(2).Cells(QnxtRow, 13).Value = 1
        QCRow = QCRow + 1 'Index QCRow counter for shift 1
    Else
        For ShiftCnt = 1 To 6
            If Sheets(1).Cells(QCRow, 2) = Sheets(1).Cells(QCRow - 1, 2) And Sheets(1).Cells(QCRow, 1) = Sheets(1).Cells(QCRow - 1, 1) Then
                Sheets(2).Cells(QnxtRow, QCol + ShiftCnt).Value = Sheets(1).Cells(QCRow, 4).Value
                Dim Stringer2 As String
                Stringer2 = Sheets(1).Cells(QCRow, 4).Value
                If InStr(1, Stringer2, "SSP") <> 0 Then Sheets(2).Cells(QnxtRow, 12).Value = 1
                If InStr(1, Stringer2, "BC") <> 0 Then Sheets(2).Cells(QnxtRow, 13).Value = 1
                QCRow = QCRow + 1 'Index QCRow counter for shift 1
            End If
        Next ShiftCnt 'Ends ShiftCnt For-Loop
    End If
    'QnxtRow = QnxtRow + 1
    'If QCRow = 10 Then Exit Do
Loop

End Sub

VBA Excel Identify repeated values in different columns and transpose values

1 Answers1