VBA Excel Определение повторяющихся значений в разных столбцах и транспонирование значений - PullRequest
Новая
       31

VBA Excel Определение повторяющихся значений в разных столбцах и транспонирование значений

0 голосов
/ 05 мая 2018

Я хочу определить, когда у человека в столбце 2 есть несколько записей в один и тот же день (столбец 1) - до 6 записей на человека в день. Затем я объединяю их в 1 строку на последующем листе и перемещаю данные в столбец 3 Данные сортируются по дате в столбце 1, а затем по алфавиту в столбце 2.

У меня есть некоторый код, который я не хочу публиковать, потому что я думаю, что выбрал плохую стратегию с циклом Do..Until при индексации номера строки. Мне нужна другая стратегия. У меня также есть ~ 10000 строк, поэтому необходим VBA и высокая эффективность ... наша лаборатория имеет только 32-битное превосходство: 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

1 Ответ

0 голосов
/ 06 мая 2018 
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
...