[已解决]怎么加添下代码，让生成数据多一项内容

mathking77

我想把J列的数据（部门名称），加添到生成后的Q列
原先的代码表格里已经有了，需要加添下，自己照着写老是不对

请教下

最佳答案

月排行榜 / 总排行榜

scl5801

2016-6-28 14:43

mathking77 发表于 2016-6-28 13:12

Sub xx()
Dim arr, d, n&, brr()
    Set d = CreateObject("Scripting.Dictionary")
    With Sheet1
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range("A2:J" & n)
        ReDim brr(i To n)
        For i = 1 To n - 1
            If Not d.Exists(arr(i, 7)) Then
                d.Add arr(i, 7), arr(i, 7)
                j = j + 1
                brr(j) = arr(i, 10)
               
                Set d(arr(i, 7)) = CreateObject("Scripting.Dictionary")
            End If
            If arr(i, 2) <= TimeValue("14:00:00") Then
                If d(arr(i, 7)).Exists("中餐次数") Then
                    d(arr(i, 7))("中餐次数") = d(arr(i, 7))("中餐次数") + 1
                Else
                    d(arr(i, 7))("中餐次数") = 1
                End If
            Else
                If d(arr(i, 7)).Exists("晚餐次数") Then
                    d(arr(i, 7))("晚餐次数") = d(arr(i, 7))("晚餐次数") + 1
                Else
                    d(arr(i, 7)).Add "晚餐次数", 1
                End If
            End If
        Next
        x = 1
        .Cells(x, 14) = "姓名"
        .Cells(x, 15) = "中餐次数"
        .Cells(x, 16) = "晚餐次数"
        For Each k In d.keys
            x = x + 1
            .Cells(x, 14) = k
            .Cells(x, 15) = d(k)("中餐次数")
            .Cells(x, 16) = d(k)("晚餐次数")
            .Cells(x, 17) = brr(x - 1)
        Next
    End With
End Sub

跳转到最佳答案楼层

mathking77

scl5801

mathking77 发表于 2016-6-28 13:12

Sub xx()
Dim arr, d, n&, brr()
    Set d = CreateObject("Scripting.Dictionary")
    With Sheet1
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range("A2:J" & n)
        ReDim brr(i To n)
        For i = 1 To n - 1
            If Not d.Exists(arr(i, 7)) Then
                d.Add arr(i, 7), arr(i, 7)
                j = j + 1
                brr(j) = arr(i, 10)
               
                Set d(arr(i, 7)) = CreateObject("Scripting.Dictionary")
            End If
            If arr(i, 2) <= TimeValue("14:00:00") Then
                If d(arr(i, 7)).Exists("中餐次数") Then
                    d(arr(i, 7))("中餐次数") = d(arr(i, 7))("中餐次数") + 1
                Else
                    d(arr(i, 7))("中餐次数") = 1
                End If
            Else
                If d(arr(i, 7)).Exists("晚餐次数") Then
                    d(arr(i, 7))("晚餐次数") = d(arr(i, 7))("晚餐次数") + 1
                Else
                    d(arr(i, 7)).Add "晚餐次数", 1
                End If
            End If
        Next
        x = 1
        .Cells(x, 14) = "姓名"
        .Cells(x, 15) = "中餐次数"
        .Cells(x, 16) = "晚餐次数"
        For Each k In d.keys
            x = x + 1
            .Cells(x, 14) = k
            .Cells(x, 15) = d(k)("中餐次数")
            .Cells(x, 16) = d(k)("晚餐次数")
            .Cells(x, 17) = brr(x - 1)
        Next
    End With
End Sub