Question

我正在尝试使用VBA将报表中的数据转置/重新格式化，以将员工姓名复制到新工作表中，然后将错过的打卡次数，倒入，倒出等复制到具有这些标题的列中。诀窍是可变行，具体取决于员工是否没有考勤卡问题，或者是否有几种不同的考勤卡问题。

此报告的长度可能有所不同，但A列中存在“总计”，可能会触发循环停止。在每个Employee块之间有一个空白单元格，它可能会触发do直到循环移动到H列并找到列出的每个问题的计数。

输入：

所需的输出：

感谢任何帮助！

我已经尝试过使用PasteSpecial Transpose进行实验，但是我的问题是要从B43单元格开始循环，并让其将Name，Paste粘贴到新表中，然后将所有考勤卡问题复制并粘贴到下一页的列中。

Answer 1

这是草稿，可以对真实数据进行一些其他测试。枢轴列的宽度必须为std宽度，并且其列标题必须进行包装。它汇总了重复的名称（例如Trumpy，Trump）。

Option Explicit
Option Base 1

Sub do_TransposeData()

    Const colNewName As Integer = 1
    Const colNameAndExcept As Integer = 2
    Const col4Transpose As Integer = 7
    Const colTally As Integer = 8

    Dim Sheet As Excel.Worksheet, thisSheet As String
    Set Sheet = ThisWorkbook.ActiveSheet
    thisSheet = ThisWorkbook.ActiveSheet.Name

    Const wsNewJustEE As String = "NewJustEE"
    Const wsNewPivot As String = "NewPivot"
    Dim ws As Excel.Worksheet
    For Each ws In Worksheets
        If ws.Name = wsNewJustEE Or ws.Name = wsNewPivot Then
            Application.DisplayAlerts = False
            Sheets(ws.Name).Delete
            Application.DisplayAlerts = True
        End If
    Next
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsNewJustEE
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsNewPivot

    Sheets(wsNewJustEE).Select
    Dim colHeads  As Variant, newRow As Long, newCol As Long
    colHeads = Array("Employee", "NameOrExcept", "cc", "dd", "ee", "ff", "ExTranspose", "ExCount")  '  <<<<<<<<<<<<<<<<<<<<
    newRow = 1
    For newCol = 1 To 8
        Sheets(wsNewJustEE).Cells(newRow, newCol) = colHeads(newCol)
    Next newCol





    Dim sPriorRowName As String, sThisRowName As String, sSavedName As String
    Dim flagInNames As Boolean, flagInExceptions As Boolean

    Dim nRow As Long, maxRow As Long
    maxRow = Sheet.Cells(Sheet.Rows.Count, "B").End(xlUp).Row


    For nRow = 1 To maxRow

        sPriorRowName = sThisRowName
        sThisRowName = Sheet.Cells(nRow, colNameAndExcept)

        If (flagInNames) Then
            ' need to test from bottom up
            If (sThisRowName = "TOTALS") Then
                flagInExceptions = False
            End If

            If (flagInExceptions And sThisRowName <> "EXCEPTIONS") Then
                newRow = newRow + 1
                For newCol = 1 To 8
                    Sheets(wsNewJustEE).Cells(newRow, newCol) = Sheets(thisSheet).Cells(nRow, newCol)
                Next newCol
                Sheets(wsNewJustEE).Cells(newRow, colNewName) = sSavedName
                Sheets(wsNewJustEE).Cells(newRow, col4Transpose) = "4Transpose"
            End If

            If (sThisRowName = "EXCEPTIONS" And Not flagInExceptions) Then
                sSavedName = sPriorRowName
                flagInExceptions = True
            End If
        End If

        If (sThisRowName = "NAME") Then
            flagInNames = True
        End If

    Next nRow

    Sheets(wsNewJustEE).Select
    Cells.Select
    Sheets(wsNewPivot).Select
    do_Pivot

End Sub

'    Sheets("NewJustEE").Select
'    Cells.Select
'    Sheets.Add
'    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
'        "NewJustEE!R1C1:R65536C8", Version:=xlPivotTableVersion10).CreatePivotTable _
'        TableDestination:="Sheet4!R3C1", TableName:="PivotTable1", DefaultVersion _
'        :=xlPivotTableVersion10
'    Sheets("Sheet4").Select
'    Cells(3, 1).Select
'    Application.Goto Reference:="Macro1"



Sub do_Pivot()

    'Sheets.Add
    'ThisWorkbook.ActiveSheet.Name = "NewPivot"

    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "NewJustEE!R1C1:R65536C8", Version:=xlPivotTableVersion10).CreatePivotTable _
        TableDestination:="NewPivot!R3C1", TableName:="PivotTable3", DefaultVersion _
        :=xlPivotTableVersion10
    Sheets("NewPivot").Select
    Cells(3, 1).Select
    With ActiveSheet.PivotTables("PivotTable3").PivotFields("ExTranspose")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable3").PivotFields("ExTranspose")
        .PivotItems("(blank)").Visible = False
    End With
    ActiveSheet.PivotTables("PivotTable3").AddDataField ActiveSheet.PivotTables( _
        "PivotTable3").PivotFields("ExCount"), "Count of ExCount", xlCount
    With ActiveSheet.PivotTables("PivotTable3").PivotFields("ExTranspose")
        .Orientation = xlPageField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable3").PivotFields("Count of ExCount")
        .Caption = "Sum of ExCount"
        .Function = xlSum
    End With
    With ActiveSheet.PivotTables("PivotTable3").PivotFields("Employee")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable3").PivotFields("NameOrExcept")  '<<<<<<<<<<<<<<<<<
        .Orientation = xlColumnField
        .Position = 1
    End With
    Rows("4:4").Select
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("B:B").ColumnWidth = 4.86
End Sub

Answer 2

这里是我想您可能需要的尝试。希望对您有所帮助。

    Option Explicit


    Const cEnd As String = "grand totals"
    Const cName As String = "name"
    Const cEx As String = "exceptions"
    Const cTot As String = "total"
    Const cID As String = "id"
    Const cTots As String = "totals"

    Const cEA As String = "excused absence"
    Const cLO As String = "late out"
    Const cLI As String = "late in"
    Const cVLO As String = "very late out"
    Const cEI As String = "early in"
    Const cEO As String = "early out"
    Const cMOP As String = "missed out punch"
    Const cUA As String = "unexcused absence"
    Const cBOS As String = "break out of sequence"
    Const cMIP As String = "missed in punch"
    Const cVEI As String = "very early in"
    Const cSB As String = "short break"


    Private Type udtEmployees
        Name As String
        ExcusedAbsence As Integer
        LateOut As Integer
        LateIn As Integer
        VeryLateOut As Integer
        EarlyIn As Integer
        EarlyOut As Integer
        MissedOutPunch As Integer
        UnexcusedAbsence As Integer
        BreakOutOfSequence As Integer
        MissedInPunch As Integer
        VeryEarlyIn As Integer
        ShortBreak As Integer
    End Type

    Private uEmps() As udtEmployees

    Public Sub GetEmployeeData()
        Dim lngI As Long
        Dim lngJ As Long
        Dim strTemp As String
        Dim strGrandTotals As String
        Dim blnEnd As Boolean
        Dim blnMainStart As Boolean
        Dim blnEmpStart As Boolean
        Dim lngCnt As Long
        Dim strB As String
        Dim strD As String
        Dim strH As String

        Dim strSheet As String
        Dim strOutSheet As String

        strSheet = "Sheet1"
        strOutSheet = "Sheet2"

        lngI = 1
        blnEnd = False
        blnMainStart = False
        blnEmpStart = False
        lngCnt = 0
        Do Until blnEnd
            With Worksheets(strSheet)

                strTemp = LCase(Trim(.Cells(lngI, 1).Value))


                If strTemp = cEnd Then
                    blnEnd = True
                Else
                    'Look for NAME(B), ID(D), TOTAL(H) = START NAME LOOK UP.
                    strB = LCase(Trim(.Cells(lngI, 2).Value))
                    strD = LCase(Trim(.Cells(lngI, 4).Value))
                    strH = LCase(Trim(.Cells(lngI, 8).Value))

                    'prevent type mismatch
                    If Len(strH) < 1 Then strH = "0"

                    If (strB = cName) And (strD = cID) And (strH = cTot) Then
                        blnMainStart = True
                    Else
                        If blnMainStart Then
                            If (strB = cEx) And (strH = cTot) And (blnEmpStart = False) Then
                                blnEmpStart = True
                                ReDim Preserve uEmps(0 To lngCnt)
                                'Get the person's name!
                                uEmps(lngCnt).Name = Trim(.Cells(lngI - 1, 2).Value)
                            End If

                            If (strB = cTots) Then
                                blnEmpStart = False
                                lngCnt = lngCnt + 1
                            End If
                            If blnEmpStart Then
                                Select Case strB
                                  Case cEA
                                      uEmps(lngCnt).ExcusedAbsence = CInt(strH)
                                  Case cLO
                                      uEmps(lngCnt).LateOut = CInt(strH)
                                  Case cLI
                                      uEmps(lngCnt).LateIn = CInt(strH)
                                  Case cVLO
                                      uEmps(lngCnt).VeryLateOut = CInt(strH)
                                  Case cEI
                                      uEmps(lngCnt).EarlyIn = CInt(strH)
                                  Case cEO
                                      uEmps(lngCnt).EarlyOut = CInt(strH)
                                  Case cMOP
                                      uEmps(lngCnt).MissedOutPunch = CInt(strH)
                                  Case cUA
                                      uEmps(lngCnt).UnexcusedAbsence = CInt(strH)
                                  Case cBOS
                                      uEmps(lngCnt).BreakOutOfSequence = CInt(strH)
                                  Case cMIP
                                      uEmps(lngCnt).MissedInPunch = CInt(strH)
                                  Case cVEI
                                      uEmps(lngCnt).VeryEarlyIn = CInt(strH)
                                  Case cSB
                                      uEmps(lngCnt).ShortBreak = CInt(strH)
                                  Case Else
                                      'Do nothing, probably a blank!
                                End Select
                            End If
                        End If
                    End If
                End If
            End With
            lngI = lngI + 1
        Loop

        'Write out the Headers
        lngI = 1
        lngJ = 1
        With Worksheets(strOutSheet)
            'First, set Up the columns
            lngJ = lngJ + 1
            .Cells(lngI, lngJ).Value = "Excused Absence"

            lngJ = lngJ + 1
            .Cells(lngI, lngJ).Value = "Late Out"

            lngJ = lngJ + 1
            .Cells(lngI, lngJ).Value = "Late In"

            lngJ = lngJ + 1
            .Cells(lngI, lngJ).Value = "Very Late Out"

            lngJ = lngJ + 1
            .Cells(lngI, lngJ).Value = "Early In"

            lngJ = lngJ + 1
            .Cells(lngI, lngJ).Value = "Early Out"

            lngJ = lngJ + 1
            .Cells(lngI, lngJ).Value = "Missed Out Punch"

            lngJ = lngJ + 1
            .Cells(lngI, lngJ).Value = "Unexcused Absence"

            lngJ = lngJ + 1
            .Cells(lngI, lngJ).Value = "Break Out Of Sequence"

            lngJ = lngJ + 1
            .Cells(lngI, lngJ).Value = "Missed In Punch"

            lngJ = lngJ + 1
            .Cells(lngI, lngJ).Value = "Very Early In"

            lngJ = lngJ + 1
            .Cells(lngI, lngJ).Value = "Short Break"

            'Finally, write out the data.
            lngI = 1
            For lngCnt = 0 To UBound(uEmps)
                lngJ = 1
                lngI = lngI + 1
                .Cells(lngI, lngJ).Value = uEmps(lngCnt).Name
                lngJ = lngJ + 1
                .Cells(lngI, lngJ).Value = uEmps(lngCnt).ExcusedAbsence
                lngJ = lngJ + 1
                .Cells(lngI, lngJ).Value = uEmps(lngCnt).LateOut
                lngJ = lngJ + 1
                .Cells(lngI, lngJ).Value = uEmps(lngCnt).LateIn
                lngJ = lngJ + 1
                .Cells(lngI, lngJ).Value = uEmps(lngCnt).VeryLateOut
                lngJ = lngJ + 1
                .Cells(lngI, lngJ).Value = uEmps(lngCnt).EarlyIn
                lngJ = lngJ + 1
                .Cells(lngI, lngJ).Value = uEmps(lngCnt).EarlyOut
                lngJ = lngJ + 1
                .Cells(lngI, lngJ).Value = uEmps(lngCnt).MissedOutPunch
                lngJ = lngJ + 1
                .Cells(lngI, lngJ).Value = uEmps(lngCnt).UnexcusedAbsence
                lngJ = lngJ + 1
                .Cells(lngI, lngJ).Value = uEmps(lngCnt).BreakOutOfSequence
                lngJ = lngJ + 1
                .Cells(lngI, lngJ).Value = uEmps(lngCnt).MissedInPunch
                lngJ = lngJ + 1
                .Cells(lngI, lngJ).Value = uEmps(lngCnt).VeryEarlyIn
                lngJ = lngJ + 1
                .Cells(lngI, lngJ).Value = uEmps(lngCnt).ShortBreak
            Next lngCnt
        End With
    End Sub

通过循环在Excel中转置数据

2 个答案:

通过循环在Excel中转​​置数据

2 个答案:

通过循环在Excel中转置数据