Excel表格取多行数据中的唯一值及多条件数据查询问题

有这样一份Excel的原始数据（隐藏了部分行）：

需要将它转换成下面的形式（隐藏了部分列）：

观察两个表，发现第一步需要将源数据中A列的名字取出唯一值。这在支持unique函数的版本中是很简单的事，只需要在目标区域第一个单元格中输入：

=UNIQUE(A:A)

即可。但是较老的版本并不支持unique函数，怎么获取唯一值呢？下面给出一个低版本Excel的方法。在源数据表中找到一个空白区（推荐紧邻数据区最后一列），例如H1单元格，在其中输入：

=IF(COUNTIF( $A$ 1:A1, A1)=1, ROW(), "")

然后一直下拉到最后一行数据，可以看到H列中出现了一系列数字，每个数字对应一个名字第一次出现的行号。这个公式说明如下：

COUNTIF( $A$ 1:A1, A1)
从A列第1行到公式所在行，对公式所在行第一列的数据（即公式对应行的"姓名"）进行计数
ROW()
返回公式所在行行号
=IF(COUNTIF( $A$ 1:A1, A1)=1, ROW(), "")

如果COUNTIF($A$1:A1, A1)计数结果为1，则公式所在单元格的值为公式所在行的行号，否则为空字符串

根据上面的公式返回的行号在A列中查找，就很容易找到姓名了。再以下一列作为辅助列，在I1单元格输入下面的公式，查出唯一姓名：

=IFERROR(INDEX(A:A, SMALL(H:H, ROW())), "")

这个公式说明如下：

SMALL(H:H, ROW())
返回h列中第ROW()小的数据。实际上就是从小到大将H列中的数字排序依次返回。
INDEX(A:A, SMALL(H:H, ROW()))
在A列中查找第 SMALL(H:H, ROW())个数据，实际上就是返回查到的名字。
IFERROR(INDEX(A:A, SMALL(H:H, ROW())), "")
如果发生错误则返回空字符串。当H列单元格值为空字符串时会发生错误。如果SMALL函数第一个参数给出具体范围，就可以不包装IFERROR函数，也就是说，这个公式也可以改为：

=INDEX(A:A, SMALL( $H$ 1: $H$ 6, ROW()))

上面的6需要根据H列中实际数据行数修改。

到这里，辅助列的结果如下：

接下来要在结果区域将一行姓名变成两行。以L列作为结果区域起始列的话，在L2单元格输入下面的公式然后下拉：

=IF(MOD(ROW(),2)=0,INDEX( $I$ 2: $I$ 100, INT((ROW())/2)),"")

公式中的区域结束单元格行号100可根据I列中实际数据行数修改。公式的含义是：偶数行（(MOD(ROW(),2)=0）单元格值为I列中第二行起的第INT((ROW())/2)个数值，奇数行单元格为空白。然后在第一行填上日期，在班次区域填上班次，就可以查找时间了。

查找时间实际上要满足两个条件：源数据区的姓名与结果区的姓名相同且源数据区的日期与结果区的日期相同。我们在N2单元格输入公式：

=IFERROR(INDEX( $C$ 2: $C$ 100,MATCH(1, INDEX(( $A$ 2: $A$ 100= $L2)\*($ B $2:$ B $100=N$ 1), 0), 0)),"")

然后在N3单元格输入公式：

=IFERROR(INDEX( $D$ 2: $D$ 100,MATCH(1, INDEX(( $A$ 2: $A$ 100= $L2)\*($ B $2:$ B $100=N$ 1), 0), 0)),"")

公式输入完成后，选择N2单元格和N3单元格，分别向右、向下拉动公式，即可完成数据填充。最终结果如下：

注意：N2单元格和N3单元格中的公式都是数组公式，低版本Excel在输入完成后需要按 Ctrl + Shift + Enter 输入。

除了通过公式完成转换外，还可以用VBA完成同样的任务，并且功能更为强大。例如，由于公式不能实现合并单元格，所以上面的姓名上下单元格合并尚需手动，但VBA则可一次完成单元格的合并。下面的宏创建一个新的数据表保存转换后的结果，其中有详细注释：

vbnet 复制代码

Sub ConvertTable()
    Dim wsSrc, wsDest  As Worksheet
    Dim lastRow, lastCol As Long
    Dim i, r, c As Long, preCol%, firstRow%
    Dim dictOn, dictOff, uName, Fun As Object
    Dim key, srcName, destName As String, name As Variant
    Dim agreeDel As VbMsgBoxResult, checkAgain As Boolean
    
    ' 原始数据所在工作表名称
    srcName = "源数据"
    ' 保存转换结果的工作表名称
    destName = "结果"
    ' 缩写Excel工作表内置函数调用前缀
    Set Fun = Application.WorksheetFunction
    ' 源数据工作表
    Set wsSrc = ThisWorkbook.Sheets(srcName)
    ' 目标数据区1日前的列数
    preCol = 2
    '==== 1. 把原始数据装入字典 ====
    Set dictOn = CreateObject("Scripting.Dictionary")
    Set dictOff = CreateObject("Scripting.Dictionary")
    Set uName = CreateObject("Scripting.Dictionary")
    ' 获取表中非空行总行数，下面的获取A列最后一个非空行也可达到此宏的目的
    ' lastRow = wsSrc.UsedRange.Rows.Count
    ' 获取A列最后一个非空行
    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
    ' 从数据区起始位置至数据区最后一行
    For i = 2 To lastRow
        uName(CStr(wsSrc.Cells(i, "A").Value)) = 1 ' 源数据姓名在A列，这个过程可以过滤相同的姓名
        ' 将姓名（A列）与日期（B列）连接起来作为上班及下班时间字典的键
        key = CStr(wsSrc.Cells(i, "A").Value) & "|" & CLng(wsSrc.Cells(i, "B").Value)
        dictOn(key) = wsSrc.Cells(i, "C").Value   '上班时间（C列）
        dictOff(key) = wsSrc.Cells(i, "D").Value  '下班时间（D列）
    Next i
    
    '==== 2. 准备结果工作表，防止防止误覆盖已存在工作表 ====
    Application.DisplayAlerts = False
    On Error Resume Next
    Do
        ' 检查结果工作表名称是否存在
        Set wsDest = ThisWorkbook.Sheets(destName)
        If Err.Number = 0 Then
            ' 结果工作表名称存在则询问用户是否删除已存在的工作表
            agreeDel = MsgBox("工作表""" & destName & """已存在，是否删除？", vbYesNo)
            If agreeDel = vbYes Then
                ' 用户同意删除，循环标志置否，并删除已存在的工作表后重新建立该工作表
                checkAgain = False
                wsDest.Delete
                Set wsDest = ThisWorkbook.Sheets.Add
                wsDest.name = destName
            Else
                ' 用户不同意删除，则要求用户输入结果工作表名称
                destName = InputBox("请输入新的工作表名称：", "重命名", destName)
                If destName = "" Then ' 用户取消输入或输入空字符串，则直至用户输入字符串
                    While destName = ""
                        destName = InputBox("请输入新的工作表名称：", "重命名", destName)
                    Wend
                End If
                ' 循环标志置是，再次检查用户输入的结果工作表名称
                checkAgain = True
            End If
        Else
            ' 用户输入了不存在的工作表名称，创建结果工作表，循环标志置否
            checkAgain = False
            Set wsDest = ThisWorkbook.Sheets.Add
            wsDest.name = destName
        End If
    Loop While checkAgain
    On Error GoTo 0
    Application.DisplayAlerts = True
    

    ' 获取日期列中出现的最大日期并加preCol
    lastCol = Fun.Max(Range(wsSrc.Cells(2, "B"), wsSrc.Cells(lastRow, "B"))) + preCol
    '==== 3. 填写结果工作表标题行（案例中第 1 行：日期、班次、1~当月最后一日）======
    wsDest.Cells(1, 1).Value = "姓名"
    wsDest.Cells(1, 2).Value = "班次"
    ' 填充日期
    For c = 1 + preCol To lastCol
        wsDest.Cells(1, c).Value = CStr(c - preCol)
    Next c
    ' 设置日期单元格数字格式为不带小数点数字
    With wsDest.Range(wsDest.Cells(1, 3), wsDest.Cells(1, lastCol))
        .NumberFormat = "0"
    End With
    
    '==== 4. 逐格填充结果工作表不同人对应的上下班时间 ====
    firstRow = 2: r = firstRow ' 第一个姓名填写行号
    With wsDest
        For Each name In uName.Keys
            .Cells(r, 1).Value = name
            .Cells(r, preCol).Value = "上班"
            .Cells(r + 1, preCol).Value = "下班"
            .Range(.Cells(r, 1), .Cells(r + 1, 1)).Merge
            
            For c = 1 + preCol To lastCol
                key = CStr(name) & "|" & CLng(c - preCol)
                '上班时间
                If dictOn.Exists(key) Then .Cells(r, c).Value = dictOn(key)
                '下班时间
                If dictOff.Exists(key) Then .Cells(r + 1, c).Value = dictOff(key)
            Next c
            r = r + 2   '跳到下一姓名填写的行号
        Next name
        ' 把时间区域设为 hh:mm 格式
        With .Range(wsDest.Cells(firstRow, preCol), wsDest.Cells(wsDest.UsedRange.Rows.Count, lastCol))
            .NumberFormat = "hh:mm"
        End With
    End With
    MsgBox "数据转换完成！", vbInformation

End Sub

上面的宏的关键思路是使用字典装入原始数据。