Excel VBA - 将数据拆分/排序成报告表格

Question

Excel VBA - 将数据拆分/排序成报告表格

3

我正在尝试将原始数据排序为报告格式。例如，我的原始数据如下图所示：

团队名称、员工姓名、他们去过的国家、所在年度季度

我希望我的数据能按照给定的格式进行拆分/排序，例如行包含团队1中员工的姓名（假设我们有6名团队1的员工），列包含所有4个季度，并且解决方案看起来像一个矩阵（6x4），其中单元格填充了国家名称。此外，如果员工在同一季度访问了美国和英国，则他的单元格显示两个国家名称。

图2是我正在寻找的解决方案：

请帮助我，我尝试编写了这个VBA代码，并成功地按团队对员工姓名进行了排序，但我不知道如何根据季度填充单元格。

Sub JMP()
Dim team1 As String
Dim team2 As String
Dim team3 As String
Dim team 4 As String

Dim Q1 As String
Dim Q2 As String
Dim Q3 As String
Dim Q4 As String

Dim finalrow As Integer
Dim i As Integer

team1 = Sheets("MasterSheet").Range("I1").Value
team2 = Sheets("MasterSheet").Range("O1").Value
team3 = Sheets("MasterSheet").Range("U1").Value

Q1 = Sheets("MasterSheet").Range("J1").Value
Q2 = Sheets("MasterSheet").Range("K1").Value
Q3 = Sheets("MasterSheet").Range("L1").Value
Q4 = Sheets("MasterSheet").Range("M1").Value

finalrow = Sheets("MasterSheet").Range("B200").End(xlUp).Row
i = 0
For i = 1 To 100
     If Cells(i, 2) = team1 And Cells(i, 5) = Q1 Then
            Range(Cells(i, 3), Cells(i, 4)).Copy
            Range("I100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
    'ElseIf Cells(i, 2) = team 1 And Cells(i, 5) = Q3 Then
            'Range(Cells(i, 3), Cells(i, 4)).Copy
            'Range("I100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
    'ElseIf Cells(i, 2) = Russia And Cells(i, 5) = Q4 Then
            'Range(Cells(i, 3), Cells(i, 4)).Copy
            'Range("I100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats

    End If

Next i


End Sub

- Shikha

有没有任何原因不能使用数据透视表？ - cronos2546

@cronos2546 - 你如何让 UK+US 显示在数据透视表值框中？虽然我同意使用行/列结构和页面筛选器来构建团队的数据透视表可能是一个很好的起点。 - Scott Holtzman

@ScottHoltzman，如果没有新的计算列（可以由VBA驱动），您将无法实现特定单元格值，但是似乎数据透视表可以满足OP所请求的许多设计目标。 - cronos2546

3个回答

1

类似这样的代码应该适用于您。您需要更新wsData（原始数据所在的工作表）、wsDest（要输出结果的工作表）和rTeams（包含原始数据的单元格范围）的工作表名称。

Sub tgr()

    Dim cTeams As Collection
    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim rFound As Range
    Dim rTeams As Range
    Dim TeamCell As Range
    Dim aTeamData() As Variant
    Dim vTeam As Variant
    Dim sFirst As String
    Dim sUnqTeams As String
    Dim sTeam As String
    Dim lQuarter As Long
    Dim lNameIndex As Long
    Dim i As Long

    Set cTeams = New Collection
    Set wsData = ActiveWorkbook.Sheets("Sheet1")
    Set wsDest = ActiveWorkbook.Sheets("Sheet2")
    Set rTeams = wsData.Range("A2", wsData.Cells(Rows.Count, "A").End(xlUp))

    For Each TeamCell In rTeams.Cells
        sTeam = CStr(TeamCell.Value)
        If InStr(1, "|" & sUnqTeams & "|", "|" & sTeam & "|", vbTextCompare) = 0 Then
            sUnqTeams = sUnqTeams & "|" & sTeam
            ReDim aTeamData(1 To WorksheetFunction.CountIf(rTeams, sTeam) + 1, 1 To 5)
            aTeamData(1, 1) = sTeam
            aTeamData(1, 2) = "Q1"
            aTeamData(1, 3) = "Q2"
            aTeamData(1, 4) = "Q3"
            aTeamData(1, 5) = "Q4"

            Set rFound = rTeams.Find(sTeam, rTeams.Cells(rTeams.Cells.Count), xlValues, xlWhole)
            If Not rFound Is Nothing Then
                sFirst = rFound.Address
                Do
                    For i = 2 To UBound(aTeamData, 1)
                        If Len(aTeamData(i, 1)) = 0 Then
                            aTeamData(i, 1) = rFound.Offset(, 1).Value
                            lNameIndex = i
                            Exit For
                        ElseIf aTeamData(i, 1) = rFound.Offset(, 1).Value Then
                            lNameIndex = i
                            Exit For
                        End If
                    Next i
                    lQuarter = Right(rFound.Offset(, 3).Value, 1) + 1
                    If Len(aTeamData(lNameIndex, lQuarter)) = 0 Then
                        aTeamData(lNameIndex, lQuarter) = rFound.Offset(, 2).Value
                    Else
                        aTeamData(lNameIndex, lQuarter) = aTeamData(lNameIndex, lQuarter) & "+" & rFound.Offset(, 2).Value
                    End If
                    Set rFound = rTeams.FindNext(rFound)
                Loop While rFound.Address <> sFirst
                cTeams.Add aTeamData, sTeam
            End If
        End If
    Next TeamCell

    wsDest.Range("A1").Resize(, UBound(aTeamData, 2)).EntireColumn.Clear
    For Each vTeam In cTeams
        wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(2).Resize(UBound(vTeam, 1), UBound(vTeam, 2)).Value = vTeam
    Next vTeam
    wsDest.Range("1:2").EntireRow.Delete xlShiftUp

End Sub

- tigeravatar

就我所知，我认为报告的数据意图是跨列的（例如，Team2在Team1右侧）。 - user4039065

@tigeravatar：谢谢您的快速回复，尽管我遇到了一个“Msg Box”的问题？我不想要任何消息框，但是一旦我删除为MsgBox编写的文本，我就会遇到错误。 - Shikha

哦，那些消息框是我用来测试和调试代码的，当我发布解决方案时，我忘记把它们删除了。我会编辑帖子将其删除。 - tigeravatar

1

一种基于数组的解决方案。

Sub reportTeam()
    Dim o As Long, n As Long, r As Long, t As Long
    Dim vTEAM As Variant, vTEAMs As Variant, vNAMEs As Variant
    Dim wsREP As Worksheet

    Set wsREP = Worksheets("Sheet2")
    ReDim vTEAMs(1 To 1)

    With Worksheets("MasterSheet")
        With .Cells(1, 1).CurrentRegion
            .Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
                        Key2:=.Columns(4), Order2:=xlAscending, _
                        Key3:=.Columns(2), Order3:=xlAscending, _
                        Orientation:=xlTopToBottom, Header:=xlYes
            With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
                vTEAMs = .Cells.Value2
                n = 0
                ReDim vNAMEs(1 To 2, 1 To 1)
                For t = LBound(vTEAMs, 1) To UBound(vTEAMs, 1)
                    n = n + 1
                    If t = UBound(vTEAMs, 1) Then
                        vNAMEs(1, UBound(vNAMEs, 2)) = n
                        vNAMEs(2, UBound(vNAMEs, 2)) = vTEAMs(t, 1)
                    ElseIf vTEAMs(t, 1) <> vTEAMs(t + 1, 1) Then
                        vNAMEs(1, UBound(vNAMEs, 2)) = n
                        vNAMEs(2, UBound(vNAMEs, 2)) = vTEAMs(t, 1)
                        ReDim Preserve vNAMEs(1 To 2, 1 To UBound(vNAMEs, 2) + 1)
                        n = 0
                    End If
                Next t
            End With
        End With
    End With

    t = 1
    With wsREP
        .UsedRange.ClearContents
        For n = LBound(vNAMEs, 2) To UBound(vNAMEs, 2)
            ReDim vTEAM(1 To vNAMEs(1, n) + 1, 1 To 5)
            r = 1
            vTEAM(r, 1) = vNAMEs(2, n)
            vTEAM(r, 2) = "Q1": vTEAM(r, 3) = "Q2": vTEAM(r, 4) = "Q3": vTEAM(r, 5) = "Q4"
            r = r + 1
            vTEAM(r, 1) = vTEAMs(t, 2)
            vTEAM(r, Right(vTEAMs(t, 4), 1) + 1) = vTEAMs(t, 3)
            r = r + 1

            For t = Application.Match(vNAMEs(2, n), Application.Index(vTEAMs, 0, 1), 0) + 1 To _
                    Application.Match(vNAMEs(2, n), Application.Index(vTEAMs, 0, 1))
                If vTEAMs(t, 2) = vTEAMs(t - 1, 2) And vTEAMs(t, 4) = vTEAMs(t - 1, 4) Then
                    vTEAM(r - 1, Right(vTEAMs(t, 4), 1) + 1) = _
                      vTEAM(r - 1, Right(vTEAMs(t, 4), 1) + 1) & Chr(43) & vTEAMs(t, 3)
                Else
                    vTEAM(r, 1) = vTEAMs(t, 2)
                    vTEAM(r, Right(vTEAMs(t, 4), 1) + 1) = vTEAMs(t, 3)
                    r = r + 1
                End If
            Next t

            With .Cells(1, Columns.Count).End(xlToLeft)
                With .Resize(UBound(vTEAM, 1), UBound(vTEAM, 2)).Offset(0, Abs(.Column > 1) * 2)
                    .Cells = vTEAM
                End With
            End With

        Next n

    End With
End Sub

我从您的代码中了解到原始数据位于名为MasterSheet的工作表上，但我找不到有关报告工作表的参考。我使用Sheet2进行报告。

- user4039065

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- omegastripes · Accepted Answer

这里以一些SQL处理和循环展示如何准备报告的例子：

Option Explicit

Sub CreateReport()

    Dim objConnection As Object
    Dim lngPosition As Long
    Dim strTeamName As Variant
    Dim objRecordSet As Object
    Dim arrData() As String
    Dim arrEmployees As Variant
    Dim lngEmployee As Long
    Dim lngQuarter As Long
    Dim arrPlaces As Variant

    ' open ADODB connection to this workbook
    Set objConnection = CreateObject("ADODB.Connection")
    objConnection.Open _
        "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "User ID=Admin;" & _
        "Data Source='" & ThisWorkbook.FullName & "';" & _
        "Mode=Read;" & _
        "Extended Properties=""Excel 12.0 Macro;"";"
    ' prepare target worksheet for output
    Sheets("Sheet2").Cells.Delete
    lngPosition = 1
    ' get names of teams
    Set objRecordSet = objConnection.Execute( _
        "SELECT DISTINCT [Team Name] FROM [Sheet1$];")
    ' process each team
    For Each strTeamName In objRecordSet.GetRows
        ' get names of particular team employees
        Set objRecordSet = objConnection.Execute( _
            "SELECT DISTINCT [Traveller's Name] FROM [Sheet1$] WHERE " & _
            "[Team Name] = '" & strTeamName & "';")
        arrEmployees = objRecordSet.GetRows
        ' prepare resulting array
        ReDim arrData(UBound(arrEmployees, 2) + 1, 4)
        arrData(0, 0) = strTeamName
        arrData(0, 1) = "Q1"
        arrData(0, 2) = "Q2"
        arrData(0, 3) = "Q3"
        arrData(0, 4) = "Q4"
        ' process each employee of the team
        For lngEmployee = 0 To UBound(arrEmployees, 2)
            arrData(lngEmployee + 1, 0) = arrEmployees(0, lngEmployee)
            ' process each quarter for the employee of the team
            For lngQuarter = 1 To 4
                ' get all visited places of the employee of the team for the quarter
                Set objRecordSet = objConnection.Execute( _
                    "SELECT DISTINCT [Country/Place] FROM [Sheet1$] WHERE " & _
                    "[Team Name] = '" & strTeamName & "' AND " & _
                    "[Traveller's Name] = '" & arrEmployees(0, lngEmployee) & "' AND " & _
                    "[Quarter] = 'Q" & lngQuarter & "';")
                If Not objRecordSet.EOF Then
                    ' if there are any places then join them and write to array
                    arrPlaces = objRecordSet.GetRows
                    arrPlaces = Application.Index(arrPlaces, , 0) ' make 1d from 2d array
                    arrData(lngEmployee + 1, lngQuarter) = Join(arrPlaces, "+")
                End If
            Next
        Next
        ' put populated array for the team to the sheet
        Output Sheets("Sheet2"), 1, lngPosition, arrData
        lngPosition = lngPosition + 6 ' shift to the right
    Next

End Sub

Sub Output(objSheet As Worksheet, lngTop As Long, lngLeft As Long, arrCells As Variant)
    With objSheet
        .Select
        .Range(.Cells(lngTop, lngLeft), .Cells(UBound(arrCells, 1) + lngTop, UBound(arrCells, 2) + lngLeft)).Value = arrCells
    End With
End Sub

我在源工作表Sheet1中填充了以下值：

然后生成的报告如下所示：

请注意，您可以从任何其他工作簿获取源数据，只需将ThisWorkbook.FullName替换为实际路径即可。在启动宏之前，必须保存对源工作簿所做的任何更改，因为连接应该是针对包含实际数据的文件进行的。它在64位版本的Excel 2010上运行良好。要使其与.xls和Excel 2003（其中未安装提供程序ACE.OLEDB.12.0）兼容，您必须将Provider=Microsoft.ACE.OLEDB.12.0;替换为Provider=Microsoft.Jet.OLEDB.4.0;，并且在扩展属性Excel 12.0 Macro;/Excel 12.0;中使用Excel 8.0;进行替换。