Question

我正在处理一个庞大的Excel工作表，我是一个完整的编程/宏新手。我希望那里有人可以给我看一个可以帮助我的宏，因为我正处于紧张状态，我不知道如何手动完成这项工作。电子表格包含与特定支付日期的员工退休金额相关的交易数据。我需要找到一种基于多个标准合并行的方法。例如，如果Emp_ID和Trans_Type匹配，那么应该将Emp_Contrib和Empr_Contrib的数量加在一起并删除额外的行，从而“合并”行。此外，如果存在Emp_ID匹配且存在列出多个Trans_Type的行的行，则应将相似的相同事务类型合并在一起，并且应将Emp_Contrib和Empr_Contrib一起添加。

基本上，当事务类型相同时，它应该为员工合并Emp_Contrib和Empr_Contrib。如果员工具有多个具有多种事务类型的行，则合并类似的事务类型。我可能没解释得这么好，所以请看下面......

以下是BEFORE的一个例子（当然是假数据）......

Emp_ID  PayDate Check_Num   Trans_Type  Fund_Desc   Emp_Contrib Empr_Contrib
2222    1/30/2015   145511  5000        Retirement  300         0
2222    1/30/2015   145511  5000        Retirement  0           52.5
4444    1/30/2015   145522  6000        Roth        1894        0
4444    1/30/2015   145522  6000        Roth        0           52.5
4444    1/30/2015   145522  7000        457         1894        0
4444    1/30/2015   145522  7000        457         26.25       0
4444    1/30/2015   145522  8000        401K        100         0
4444    1/30/2015   145522  8000        401K        0           50

这就是我需要的AFTER ......

Emp_ID  PayDate Check_Num   Trans_Type  Fund_Desc   Emp_Contrib Empr_Contrib
2222    1/30/2015   145511  5000        Retirement  300         52.5
4444    1/30/2015   145522  6000        Roth        1894        52.5
4444    1/30/2015   145522  7000        457         1920.25     0
4444    1/30/2015   145522  8000        401K        100         50

提前感谢您的帮助。

-Chris

Answer 1

要仅获取唯一行，请执行以下操作：

选择列Emp_ID，PayDate，Check_Num，Trans_Type和Fund_Desc
转到数据标签 - ＆gt;高级过滤器
在“高级过滤器”对话框中，选择“＃34;复制到其他位置”＆＃34;并检查＆＃34;仅限唯一记录＆＃34;复选框
选择要复制唯一记录的地方，我刚刚选择了单元格I1

这就是它的样子：

how to advanced filter

执行高级过滤器后，它应该是这样的：

After advanced filter

现在，您可以使用SUMIFS公式来添加数字并使用唯一行数据显示。使用我建议的位置（虽然您可以调整到您的首选位置）：

在单元格N2（对于Emp_Contrib）中，使用此公式并向下复制：=SUMIFS(F:F,A:A,I2,B:B,J2,C:C,K2,D:D,L2,E:E,M2)
在单元格O2（针对Empr_Contrib）中使用此公式并向下复制：=SUMIFS(G:G,A:A,I2,B:B,J2,C:C,K2,D:D,L2,E:E,M2)

这应该可以提供你想要的结果。

Answer 2

这是一个宏来做上述事情。

首先，插入一个类模块;将其重命名为cContributions。

然后，插入常规模块。

在常规模块中，调整工作表名称（wsSrc和wsRes）以反映您的真实工作表名称;和rRes反映你想要写结果的左上角。

请注意，我们使用Employee ID和Transaction类型的组合来创建要合并的唯一键。如果您的源表包含多个日期，并且您还希望按日期分隔，则您只需将PayDate添加到密钥。

班级单元

'RENAME Me cContributions
Option Explicit
Private pEmp_ID As String
Private pPayDate As Date
Private pCheck_Num As Long
Private pTrans_Type As String
Private pFund_Desc As String
Private pEmp_Contrib As Currency
Private pEmpr_Contrib As Currency

Public Property Get Emp_ID() As String
    Emp_ID = pEmp_ID
End Property
Public Property Let Emp_ID(Value As String)
    pEmp_ID = Value
End Property

Public Property Get PayDate() As Date
    PayDate = pPayDate
End Property
Public Property Let PayDate(Value As Date)
    pPayDate = Value
End Property

Public Property Get Check_Num() As Long
    Check_Num = pCheck_Num
End Property
Public Property Let Check_Num(Value As Long)
    pCheck_Num = Value
End Property

Public Property Get Trans_Type() As String
    Trans_Type = pTrans_Type
End Property
Public Property Let Trans_Type(Value As String)
    pTrans_Type = Value
End Property

Public Property Get Fund_Desc() As String
    Fund_Desc = pFund_Desc
End Property
Public Property Let Fund_Desc(Value As String)
    pFund_Desc = Value
End Property

Public Property Get Emp_Contrib() As Currency
    Emp_Contrib = pEmp_Contrib
End Property
Public Property Let Emp_Contrib(Value As Currency)
    pEmp_Contrib = Value
End Property

Public Property Get Empr_Contrib() As Currency
    Empr_Contrib = pEmpr_Contrib
End Property
Public Property Let Empr_Contrib(Value As Currency)
    pEmpr_Contrib = Value
End Property

常规模块

Option Explicit
Sub CombineContributions()
    Dim cC As cContributions, colC As Collection
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes() As Variant
    Dim I As Long
    Dim sKey As String

Set wsSrc = Worksheets("Sheet1")
Set wsRes = Worksheets("Sheet1")
    Set rRes = Range("I1")

'Get source data
With wsSrc
    vSrc = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(COLUMNSIZE:=7)
End With

'Collect data and combine as required
Set colC = New Collection
On Error Resume Next 'to detect combos
For I = 2 To UBound(vSrc) 'skip the header row
    Set cC = New cContributions
    With cC
        .Emp_ID = vSrc(I, 1)
        .PayDate = vSrc(I, 2)
        .Check_Num = vSrc(I, 3)
        .Trans_Type = vSrc(I, 4)
        .Fund_Desc = vSrc(I, 5)
        .Emp_Contrib = vSrc(I, 6)
        .Empr_Contrib = vSrc(I, 7)
        'create a key for uniqueness
        'if there are multiple dates in the source data, could add PayDate to the key
        sKey = .Emp_ID & "|" & .Trans_Type
        colC.Add cC, sKey
        If Err.Number = 457 Then 'combine the data
            Err.Clear
            colC(sKey).Emp_Contrib = colC(sKey).Emp_Contrib + .Emp_Contrib
            colC(sKey).Empr_Contrib = colC(sKey).Empr_Contrib + .Empr_Contrib
        ElseIf Err.Number <> 0 Then
            Debug.Print Err.Number, Err.Description
            Stop  'tells what the error is, but not where it occurred
        End If
    End With
Next I
On Error GoTo 0

'create results array
ReDim vRes(0 To colC.Count, 1 To UBound(vSrc, 2))

'header row
For I = 1 To UBound(vRes, 2)
    vRes(0, I) = vSrc(1, I)
Next I

'data
For I = 1 To colC.Count
    With colC(I)
        vRes(I, 1) = .Emp_ID
        vRes(I, 2) = .PayDate
        vRes(I, 3) = .Check_Num
        vRes(I, 4) = .Trans_Type
        vRes(I, 5) = .Fund_Desc
        vRes(I, 6) = .Emp_Contrib
        vRes(I, 7) = .Empr_Contrib
    End With
Next I

'write and format the data
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))

Application.ScreenUpdating = False
With rRes
    .EntireColumn.Clear
    .Value = vRes

    'added next line so the 457 would be left aligned.
    'could instead explicitly make it text
    .Columns(5).HorizontalAlignment = xlLeft

    With .Rows(1)
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
    End With
    .EntireColumn.AutoFit
End With
Application.ScreenUpdating = True

End Sub

使用多个条件合并行的Excel宏

2 个答案:

班级单元

常规模块