Question

我尝试使用VBA在Excel中创建报表来处理某些数据并创建一个表格报告，该报表按组汇总值。虽然我可以手动生成表格，但我无法获得完全创建此报告的代码。

输入数据：

ID | name   | number | class | comment
---|--------|--------|-------|----------       
 1 | john   |      4 | A1    | sports
---|--------|--------|-------|----------      
 1 | john   |      3 | A2    | sports
---|--------|--------|-------|----------      
 1 | john   |      5 | A3    | sports
---|--------|--------|-------|----------      
 2 | charly |      1 | B3    | tech
---|--------|--------|-------|----------     
 2 | charly |      2 | B2    | tech
---|--------|--------|-------|----------  
 2 | charly |      1 | B2    | tech
---|--------|--------|-------|----------   
 3 | frank  |      7 | C3    | language
---|--------|--------|-------|----------     
 3 | frank  |      2 | C5    | language
---|--------|--------|-------|----------  
 3 | frank  |      9 | C4    | language

新工作表中的预期摘要：

ID | name   | number  | class      | comment
---|--------|---------|------------|----------
 1 | john   | ”3,4,5” | ”A1,A2,A3” | sports
---|--------|---------|------------|----------
 2 | charly | ”1,2”   | ”B2,B3”    | tech
---|--------|---------|------------|----------
 3 | frank  | ”2,7,9” | ”C3,C4,C5” | language

以下是我目前的代码：

Function Uniques(r As Range)

Dim d As Object, c As Range, tmp
     Set d = CreateObject("scripting.dictionary")
     For Each c In rCells
        tmp = Trim(c.Value)
        If Len(tmp) > 0 Then
             If Not d.Exists(tmp) And tmp <> “HEADER” Then d.Add tmp, 1
        End If
     Next c
     Uniques = d.keysEnd Function
     With .Range("A1:N" & .Cells(.Rows.Count, 1).End(xlUp).Row)
           .AutoFilter Field:=1
           Set a = .Columns(“A”).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
           Set b = .Columns(“B”).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
           'getting the unique items
            d = Uniques(Range("D:D").SpecialCells(xlCellTypeVisible))
           .AutoFilter
     End With

Answer 1

使用字典的方法是朝着正确方向迈出的一步，尽管它需要另外一个字典对象才能在子循环中使用它。由于额外的列以及问题中预期摘要部分下所示的唯一和排序数据的要求，它变得有点复杂和有趣。

以下更新的代码假定从包含此数据的工作表触发宏并在Sheet（2）中生成输出：

select r
from Roles r
inner join Usario u on r.usu_id=u.id
where u.estactiv=true
order by r.descripcion

2 ^nd版本：

根据后续讨论，这里有一个经过修改的更精简的版本，功能更强大。在这种方法下，可以在函数调用中设置需要搜索有序和唯一列表的列。

Sub strSplit()
    Dim r As Range, lastRow As Long, k As Variant, k1 As Variant, d As Object, d1 As Object, i As Long, j As Long, cmnt As String
    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    For Each r In Range("B2:B" & lastRow)
        If Not IsEmpty(r) Then d(r.Value) = r.Offset(0, -1).Value
    Next
    For Each k In d.Keys
        i = i + 1
        Sheets(2).Cells(i + 1, 1) = d(k)
        Sheets(2).Cells(i + 1, 2) = k

        'get list of unique numbers for each ID + comment
        For Each r In Range("B2:B" & lastRow)
            If k = r.Value Then
                d1(r.Offset(0, 1).Value) = r.Value
                cmnt = r.Offset(0, 3).Value
            End If
        Next
        j = 0
        For Each k1 In d1.Keys
            If j = 0 Then Sheets(2).Cells(i + 1, 5) = cmnt
            Sheets(2).Cells(j + d.Count + 2, 3) = k1
            j = j + 1
        Next
        Set r = Sheets(2).Range("C" & d.Count + 2 & ":C" & j + 1 + d.Count)
        r.Sort r.Columns(1)
        Sheets(2).Cells(i + 1, 3) = colToRw(r)
        r.ClearContents
        d1.RemoveAll

        'get list of unique classes for each ID
        For Each r In Range("B2:B" & lastRow)
            If k = r.Value Then d1(r.Offset(0, 2).Value) = r.Value
        Next
        j = 0
        For Each k1 In d1.Keys
            Sheets(2).Cells(j + d.Count + 2, 4) = k1
            j = j + 1
        Next
        Set r = Sheets(2).Range("D" & d.Count + 2 & ":D" & j + 1 + d.Count)
        r.Sort r.Columns(1)
        Sheets(2).Cells(i + 1, 4) = colToRw(r)
        r.ClearContents
        d1.RemoveAll
    Next
    Sheets(2).Select
End Sub
Function colToRw(r As Range) As String
    Dim r1 As Range, is1st As Boolean
    is1st = True
    For Each r1 In r
        If Not is1st Then
            colToRw = colToRw & ", "
        Else: is1st = False
        End If
        colToRw = colToRw & r1.Value
    Next
End Function

Excel VBA使用分组值创建报告

1 个答案: