Question

我想确定Column2中的某个人在同一天（Column1）有多个条目的时间 - 每人每天最多6个条目。然后我将它们压缩成后续工作表中的1行，并将数据转置到Column3中。数据按列中的日期排序，然后按列2的字母顺序排序。

我有一些代码，我不想发布b / c我认为我已经选择了一个带有Do..Until循环的错误策略，同时索引行号。我需要一个不同的策略。我也有大约10,000行，所以VBA是必要的，效率值得赞赏...我们的实验室只有32位excel：P

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

Answer 1

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识别不同列中的重复值并转置值

1 个答案: