统计每月每人加班，原来是竖列想变成横列。

musicalz

1	装置制造课	包梦新	0
2	装置制造课	包梦新	0
3	装置制造课	包梦新	30.5
4	装置制造课	包梦新	23
5	装置制造课	包梦新	0
6	装置制造课	包梦新	30
7	装置制造课	包梦新	37.5
8	装置制造课	包梦新	45.5
9	装置制造课	包梦新	32.5
10	装置制造课	包梦新	50
11	装置制造课	包梦新	37.5

·
1~11月份个人加班统计（想成为如下的横列） 2014年加班汇总.zip (65.37 KB, 下载次数: 23)

2014-12-9 19:58 上传

点击文件名下载附件

编号	班组	姓名	合计	1	2	3	4	5	6	7	8	9	10	11
1	装置制造课	包梦新	286.5	0	0	30.5	23	0	30	37.5	45.5	32.5	50	37.5

chxw68

1. Sub test()
   
2.   Dim d As Object
   
3.   Dim r%, i%
   
4.   Dim arr, brr()
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:d" & r)
   
9.     mm = Application.Max(Application.Index(arr, 0, 1))
   
10.     For i = 1 To UBound(arr)
    
11.       xm = arr(i, 2) & "+" & arr(i, 3)
    
12.       If Not d.Exists(xm) Then
    
13.         ReDim brr(1 To mm + 4)
    
14.         For j = 1 To 3
    
15.           brr(j) = arr(i, j)
    
16.         Next
    
17.       Else
    
18.         brr = d(xm)
    
19.       End If
    
20.       brr(arr(i, 1) + 4) = brr(arr(i, 1) + 4) + arr(i, 4)
    
21.       brr(4) = brr(4) + arr(i, 4)
    
22.       d(xm) = brr
    
23.     Next
    
24.   End With
    
25.   With Worksheets("sheet2")
    
26.     .UsedRange.Offset(1, 0).ClearContents
    
27.     .Range("a2").Resize(d.Count, UBound(brr)) = Application.Transpose(Application.Transpose(d.Items))
    
28.   End With
    
29. End Sub
    

复制代码

chxw68

参见附件。

zhaogang1960

字典法请参考：

1. Sub Macro1()
   
2.     Dim arr, brr(), d As Object, i&, j&, m&
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheets("Sheet1").Range("A1").CurrentRegion
   
5.     ReDim brr(1 To UBound(arr), -3 To 11)
   
6.     For i = 2 To UBound(arr)
   
7.         s = arr(i, 2) & arr(i, 3)
   
8.         If Not d.Exists(s) Then
   
9.             m = m + 1
   
10.             d(s) = m
    
11.             brr(m, -3) = m
    
12.             For j = 2 To 4
    
13.                 brr(m, j - 4) = arr(i, j)
    
14.             Next
    
15.             brr(m, arr(i, 1)) = arr(i, 4)
    
16.         Else
    
17.             brr(d(s), 0) = brr(d(s), 0) + arr(i, 4)
    
18.             brr(d(s), arr(i, 1)) = brr(d(s), arr(i, 1)) + arr(i, 4)
    
19.         End If
    
20.     Next
    
21.     With Sheets("Sheet2")
    
22.         .UsedRange.Offset(1).ClearContents
    
23.         .[a2].Resize(m, 15) = brr
    
24.     End With
    
25. End Sub
    

复制代码

zhaogang1960

4楼代码假设编号最大为11，下面去掉该条件

1. Sub 编号未知()
   
2.     Dim arr, brr(), d As Object, i&, j&, m&, c&, s$
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheets("Sheet1").Range("A1").CurrentRegion
   
5.     c = Application.Max(Sheets("Sheet1").[a:a])
   
6.     ReDim brr(1 To UBound(arr), -3 To c)
   
7.     For i = 2 To UBound(arr)
   
8.         s = arr(i, 2) & arr(i, 3)
   
9.         If Not d.Exists(s) Then
   
10.             m = m + 1
    
11.             d(s) = m
    
12.             brr(m, -3) = m
    
13.             For j = 2 To 4
    
14.                 brr(m, j - 4) = arr(i, j)
    
15.             Next
    
16.             brr(m, arr(i, 1)) = arr(i, 4)
    
17.         Else
    
18.             brr(d(s), 0) = brr(d(s), 0) + arr(i, 4)
    
19.             brr(d(s), arr(i, 1)) = brr(d(s), arr(i, 1)) + arr(i, 4)
    
20.         End If
    
21.     Next
    
22.     With Sheets("Sheet2")
    
23.         .Cells.ClearContents
    
24.         .[a1:d1] = Array("编号", "班组", "姓名", "合计")
    
25.         .[e1] = 1
    
26.         .[e1].AutoFill Destination:=.[e1].Resize(, c), Type:=xlFillSeries
    
27.         .[a2].Resize(m, c + 4) = brr
    
28.     End With
    
29. End Sub

复制代码

zhaogang1960

ADO中的TransForm语句也可以实现，请参考：

1. Sub ADOTransForm()
   
2.     Dim cnn As Object, rs As Object, i&, SQL$
   
3.     Set cnn = CreateObject("ADODB.Connection")
   
4.     Set rs = CreateObject("ADODB.Recordset")
   
5.     cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
   
6.     SQL = "TRANSFORM SUM(合计) SELECT null as 编号,班组,姓名,SUM(合计) AS 合计 FROM [Sheet1$] GROUP BY 班组,姓名 PIVOT 编号"
   
7.     rs.Open SQL, cnn, 1, 3
   
8.     Cells.ClearContents
   
9.     For i = 0 To rs.Fields.Count - 1
   
10.         Cells(1, i + 1) = rs.Fields(i).Name
    
11.     Next
    
12.     Range("A2").CopyFromRecordset rs
    
13.     [a2] = 1
    
14.     [a2].AutoFill Destination:=[a2].Resize(rs.RecordCount), Type:=xlFillSeries
    
15.     rs.Close
    
16.     cnn.Close
    
17.     Set rs = Nothing
    
18.     Set cnn = Nothing
    
19. End Sub
    

复制代码

张雄友

zhaogang1960 发表于 2014-12-9 20:19
4楼代码假设编号最大为11，下面去掉该条件

For j = 2 To 4 是什么意思？摸不透。

zhaogang1960

张雄友 发表于 2014-12-9 21:16
For j = 2 To 4 是什么意思？摸不透。

第一列写编号到brr的-3列，但是不是原来的编号，而是累计号
从第二列到第四列写入brr-2到0列
brr第1列以后专门用于写合计

zax010

Sub zz()
    Dim d1, d2, arr, brr
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    arr = Sheet1.Range("A1").CurrentRegion
    Sheet2.Range("A2:O1000") = ""
    brr = Sheet2.Range("A1:O1000"): m = 1
    For i = 2 To UBound(arr)
        d1(arr(i, 2) & "," & arr(i, 3)) = ""
        d2(arr(i, 2) & arr(i, 3) & arr(i, 1)) = arr(i, 4)
    Next
    For Each k In d1.keys
        m = m + 1: s = Split(k, ","): brr(m, 1) = m - 1: brr(m, 2) = s(0): brr(m, 3) = s(1)
        For j = 5 To UBound(brr, 2)
            brr(m, j) = d2(brr(m, 2) & brr(m, 3) & brr(1, j))
            brr(m, 4) = brr(m, 4) + brr(m, j)
        Next
    Next
    Sheet2.Range("A1").Resize(m, UBound(brr, 2)) = brr
End Sub

zax010

>>>>>>>>>>>>>>>>>>>>>
2014年加班汇总.rar (56.88 KB, 下载次数: 39)

2014-12-10 09:36 上传

点击文件名下载附件