我有以下数据
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
我必须编写一个VB宏来根据公司和位置分隔记录。所以我将得到两组记录
首先设置
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
以下代码的工作原理： 首先在公司和位置上获得不同的数据集。之后它将基于主记录XX或zz过滤掉。如果该集合中的任何主记录那么它将考虑整个集合。最后在每个集合中在主记录数量上比较所有其他子记录数量。如果它匹配，那么我将复制到新工作表。
下面的代码工作正常，如果主记录xx，zz按顺序排列到子记录之后。如果我把最后一条记录放在表格“xx Jhon 100 IBM us”中。它工作得非常好。否则它不起作用。
VBA大师。对此表示赞赏。
代码iam尝试
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
有人可以帮我这个吗？
答案 0 :(得分：2)
我会使用类模块。这是一个前期工作，但更容易阅读和维护。首先，将类模块插入到项目中，并将其命名为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