Question

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

团队名称，员工姓名，他们旅行过的国家/地区年

我希望我的数据以给定格式分割/排序，例如row包含team1中员工的名称（假设我们在team1中有6名员工），列包含所有4个季度，而解决方案看起来像矩阵（6x4）国家/地区名称填写在单元格中如果员工访问过US＆amp;英国在同一季度，他的牢房显示同一牢房中的国家名称。

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

请帮助我，我尝试编写这个VBA代码并成功地将团队中的员工名称排序，但我不知道如何填写单元格w.r.t.季度？

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

Answer 1

以下是使用一些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;，并将其替换为扩展属性{{ 1}} / Excel 12.0 Macro;与Excel 12.0;。

Answer 2

这样的事情对你有用。您需要更新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

Answer 3

另一个基于阵列的解决方案。

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 进行报告。

Excel VBA - 将数据拆分/排序到报告表中

3 个答案: