Excel VBAloggingsorting
我有下面的数据
Empid Empname salary Company location status x1 Phil 50 IBM us x2 Karl 30 IBM us x3 Steve 20 IBM us x4 jacob 70 Oracle uk x5 jason 30 Oracle uk x6 stuart 50 Oracle uk zz jay 150 Oracle uk x10 Steve1 20 IBM ind x9 Steve2 20 IBM nj xx Jhon 100 IBM us 我必须写一个VBmacros来分离基于公司和位置的logging。 所以我会得到两套logging
第一套
Empid Empname salary company Location status xx Jhon 100 IBM us x1 Phil 50 IBM us x2 Karl 30 IBM us x3 Steve 20 IBM us
第二套
Empid Empname salary company Location status x4 jacob 70 Oracle uk x5 jason 30 Oracle uk x6 stuart 50 Oracle uk zz jay 150 Oracle uk
下面的代码是如何工作的：首先在公司和位置上find不同的数据集，然后根据主loggingXX或zz.fif进行过滤，如果那里的任何主logging在那里都会考虑整个集合。最后在每一组基于主logging数量比较所有其他子logging的数量。如果匹配，然后我复制到新的工作表。
下面的代码工作正常，如果主loggingxx，zz进入子logging后面的顺序。如果我把最后一个logging放在“xx Jhon 100 IBM us”表中，它工作得很好。否则它不是加工。
VBA大师。对此赞赏的任何帮助。
代码我尝试
Sub tester() Const COL_EID As Integer = 1 Const COL_comp As Integer = 4 Const COL_loc As Integer = 5 Const COL_sal As Integer = 3 Const COL_S As Integer = 6 Const VAL_DIFF As String = "XXdifferentXX" Dim d As Object, sKey As String, sKey1 As String, id As String Dim rw As Range, opt As String, rngData As Range Dim rngCopy As Range, goodId As Boolean, goodId1 As Boolean Dim FirstPass As Boolean, arr, arr1 Dim sal As Integer Dim colsal As Integer Dim mastersal As Integer Dim status As Boolean Dim status1 As Boolean With Sheet1.Range("A1") Set rngData = .CurrentRegion.Offset(1).Resize( _ .CurrentRegion.Rows.Count - 1) End With Set rngCopy = Sheet2.Range("A1") FirstPass = True SecondPass = False status = False Set a = CreateObject("scripting.dictionary") Set d = CreateObject("scripting.dictionary") redo: For Each rw In rngData.Rows sKey = rw.Cells(COL_comp).Value & "<>" & _ rw.Cells(COL_loc).Value sKey1 = rw.Cells(COL_comp).Value & "<>" & _ rw.Cells(COL_loc).Value colsal = rw.Cells(COL_sal).Value If FirstPass Then id = rw.Cells(COL_EID).Value goodId = (id = "xx" Or id = "zz") If d.exists(sKey) Then arr = d(sKey) 'can't modify the array in situ... If goodId Then arr(0) = True d(sKey) = arr 'return [modified] array Else d.Add sKey, Array(goodId) End If End If If SecondPass Then id = rw.Cells(COL_EID).Value goodId1 = (id = "xx" Or id = "zz") If d(sKey)(0) = True Then If goodId1 Then mastersal = rw.Cells(COL_sal).Value If a.exists(sKey1) Then arr1 = a(sKey1) 'can't modify the array in situ... If goodId1 = False Then sal = sal + colsal If mastersal = sal Then arr1(0) = True 'If goodId1 Then arr1(0) = True a(sKey1) = arr1 'return [modified] array Else a.Add sKey1, Array(status) sal = 0 If goodId1 = False Then sal = sal + colsal End If End If End If If FirstPass = False And SecondPass = False Then If d(sKey)(0) = True Then If a(sKey1)(0) = True Then rw.Copy rngCopy Set rngCopy = rngCopy.Offset(1, 0) End If End If End If Next rw If SecondPass Then SecondPass = False GoTo redo End If If FirstPass Then FirstPass = False SecondPass = True colsal = 0 GoTo redo End If End Sub
有人可以帮我弄这个吗？
我会使用类模块。 前面的工作稍微多一点，但更容易阅读和维护。 首先，在您的项目中插入一个类模块并将其命名为CEmployee。 这个代码进入CEmployee
Option Explicit Private mlEmployeeID As Long Private msEmpid As String Private msEmpName As String Private mdSalary As Double Private msCompany As String Private msLocation As String Private Const msDELIM As String = "|" Public Property Get Location() As String: Location = msLocation: End Property Public Property Let Location(ByVal sLocation As String): msLocation = sLocation: End Property Public Property Get Company() As String: Company = msCompany: End Property Public Property Let Company(ByVal sCompany As String): msCompany = sCompany: End Property Public Property Get Salary() As Double: Salary = mdSalary: End Property Public Property Let Salary(ByVal dSalary As Double): mdSalary = dSalary: End Property Public Property Get EmpName() As String: EmpName = msEmpName: End Property Public Property Let EmpName(ByVal sEmpName As String): msEmpName = sEmpName: End Property Public Property Get Empid() As String: Empid = msEmpid: End Property Public Property Let Empid(ByVal sEmpid As String): msEmpid = sEmpid: End Property Public Property Get EmployeeID() As Long: EmployeeID = mlEmployeeID: End Property Public Property Let EmployeeID(ByVal lEmployeeID As Long): mlEmployeeID = lEmployeeID: End Property Public Property Get CompLoc() As String CompLoc = Me.Company & msDELIM & Me.Location End Property Public Property Get IsMaster() As Boolean IsMaster = Me.Empid = String(2, Left$(Me.Empid, 1)) End Property
接下来，在CEmployees（复数）中插入另一个类模块和名称。 您必须修改此模块，如http://www.dailydoseofexcel.com/archives/2010/07/04/custom-collection-class/所示，以便能够使用For Each循环访问该对象。 CEmployees的代码是
Option Explicit Private mcolEmployees As Collection Private Sub Class_Initialize() Set mcolEmployees = New Collection End Sub Private Sub Class_Terminate() Set mcolEmployees = Nothing End Sub Public Property Get NewEnum() As IUnknown Set NewEnum = mcolEmployees.[_NewEnum] End Property Public Sub Add(clsEmployee As CEmployee) If clsEmployee.EmployeeID = 0 Then clsEmployee.EmployeeID = Me.Count + 1 End If mcolEmployees.Add clsEmployee, CStr(clsEmployee.EmployeeID) End Sub Public Property Get Employee(vItem As Variant) As CEmployee Set Employee = mcolEmployees.Item(vItem) End Property Public Property Get Count() As Long Count = mcolEmployees.Count End Property Public Sub FillFromRange(rRng As Range) Dim rCell As Range Dim clsEmployee As CEmployee For Each rCell In rRng.Columns(1).Cells Set clsEmployee = New CEmployee With clsEmployee .Empid = rCell.Value .EmpName = rCell.Offset(0, 1).Value .Salary = rCell.Offset(0, 2).Value .Company = rCell.Offset(0, 3).Value .Location = rCell.Offset(0, 4).Value End With Me.Add clsEmployee Next rCell End Sub Public Property Get UniqueCompLoc() As Collection Dim colReturn As Collection Dim clsEmployee As CEmployee Set colReturn = New Collection For Each clsEmployee In Me On Error Resume Next colReturn.Add clsEmployee.CompLoc, clsEmployee.CompLoc On Error GoTo 0 Next clsEmployee Set UniqueCompLoc = colReturn End Property Public Property Get FilterCompLoc(sCompLoc As String) As CEmployees Dim clsEmployee As CEmployee Dim clsReturn As CEmployees Set clsReturn = New CEmployees For Each clsEmployee In Me With clsEmployee If .CompLoc = sCompLoc Then clsReturn.Add clsEmployee End If End With Next clsEmployee Set FilterCompLoc = clsReturn End Property Public Property Get SalaryMatch() As Boolean Dim clsEmployee As CEmployee Dim dSalary As Double, dMaster As Double For Each clsEmployee In Me If clsEmployee.IsMaster Then dMaster = clsEmployee.Salary Else dSalary = dSalary + clsEmployee.Salary End If Next clsEmployee SalaryMatch = dMaster = dSalary End Property Public Property Get OutputToRange() As Variant Dim aReturn() As Variant Dim clsEmployee As CEmployee Dim i As Long ReDim aReturn(1 To Me.Count, 1 To 5) For Each clsEmployee In Me i = i + 1 With clsEmployee aReturn(i, 1) = .Empid aReturn(i, 2) = .EmpName aReturn(i, 3) = .Salary aReturn(i, 4) = .Company aReturn(i, 5) = .Location End With Next clsEmployee OutputToRange = aReturn End Property
最后，将一个标准模块添加到您的项目并包含此代码。
Option Explicit Public gclsEmployees As CEmployees Sub CopyRanges() Dim clsEmployee As CEmployee Dim clsFiltered As CEmployees Dim colCompLoc As Collection Dim i As Long Dim rNext As Range Dim vaOutput As Variant Sheet2.UsedRange.ClearContents 'Create a new CEmployees and fill it with CEmployee objects Set gclsEmployees = New CEmployees gclsEmployees.FillFromRange Sheet1.Range("A2:E11") 'Get a list of unique company/location combinations Set colCompLoc = gclsEmployees.UniqueCompLoc 'loop through the unique combinations For i = 1 To colCompLoc.Count 'create a new CEmployees containing only that combination Set clsFiltered = gclsEmployees.FilterCompLoc(colCompLoc(i)) 'if the salaries add up to the master If clsFiltered.SalaryMatch Then 'write the employee out to sheet2 Set rNext = Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(1, 0) vaOutput = clsFiltered.OutputToRange rNext.Resize(UBound(vaOutput, 1), UBound(vaOutput, 2)).Value = vaOutput End If Next i End Sub
你可以看到我在http://dl.dropbox.com/u/1347353/FilterEmployees.xls创build的示例文件