Excel VBA – 将数据拆分/分类到报表中

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

团队名称,员工姓名,他们旅行的国家,季度

在这里输入图像说明

我希望我的数据按照给定的格式进行拆分/sorting,比如row包含team1中员工的名字(假设我们在team1中有6名员工),列中包含所有4个季度,解决scheme看起来像matrix(6×4),其中国家名称是填充单元格。 另外,如果员工在同一季度访问过美国和英国,他的手机将同时显示两个国家的姓名。

图2是我正在寻找的解决scheme: 在这里输入图像说明

请帮助我,我试图写这个VBA代码,并成功地sorting在团队中的员工姓名,但我不知道如何填写单元格的Wrt Quarters?

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 

另外一个基于arrays的解决

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

以下是如何使用一些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.FullNamereplace为实际path。 在启动macros之前,对源工作簿所做的任何更改都必须保存,因为连接应该完成到包含实际数据的文件。 它适用于64位版本的Excel 2010。 为了使其与.xls和Excel 2003(未安装提供程序ACE.OLEDB.12.0 )兼容,您必须replaceProvider=Microsoft.ACE.OLEDB.12.0;Provider=Microsoft.Jet.OLEDB.4.0; ,并在扩展属性Excel 12.0 Macro; / Excel 12.0;Excel 8.0;

像这样的东西应该为你工作。 您需要更新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