[已解决]分享并求肋

sunche

老师们中午好！我最近在学编VBA代码！但运行时出了点问题，请各位老师斧正！修改后的代码在宏中，仍未最终成功。原来的代码在sheet2中，运行中出现的问题和要达到的目的在sheet1中。谢谢！

最佳答案

月排行榜 / 总排行榜

chart888

2017-6-6 14:54

1. Sub aaa()
   
2. Dim Arr, myPath$, myName$, Arr1, i&, j&, x$, y$
   
3. Dim crr2(1 To 10000, 1 To 3)
   
4. Dim d, d1, bt, k, t, k1, aa, s$
   
5. Dim bb, m&, col&
   
6. Set d = CreateObject("Scripting.Dictionary")
   
7. Set d1 = CreateObject("Scripting.Dictionary")
   
8. Application.DisplayAlerts = False
   
9. Application.ScreenUpdating = False
   
10. 
    
11. Sheet1.Activate
    
12. bt = Array("工作时间", "加班时间")
    
13. [a3:e5000].Clear
    
14. [f1:bz5002].Clear
    
15. Cells.Font.Size = 11
    
16. myPath = ThisWorkbook.Path & ""
    
17. myName = Dir(myPath & "*.xls")
    
18. Do While myName <> ""
    
19.     If InStr(myName, "汇总") = 0 Then
    
20.        With GetObject(myPath & myName)
    
21.            Arr1 = .Sheets(1).[a1].CurrentRegion
    
22.            For i = 3 To UBound(Arr1)
    
23.                x = Arr1(i, 2)
    
24.                y = Split(myName, ".")(0)
    
25.                If d.exists(x) = False Then
    
26.                     Set d(x) = CreateObject("Scripting.Dictionary")
    
27.                     nn = nn + 1
    
28.                     crr2(nn, 1) = Arr1(i, 3)
    
29.                     crr2(nn, 2) = Arr1(i, 4)
    
30.                     crr2(nn, 3) = Arr1(i, 5)
    
31.                End If
    
32.                d(x)(y) = d(x)(y) & Arr1(i, 6) & "|" & Arr1(i, 7)
    
33.                d1(y) = ""
    
34.            Next
    
35.            .Close False
    
36.        End With
    
37.     End If
    
38. myName = Dir
    
39. Loop
    
40. k = d.keys: t = d.items: k1 = d1.keys
    
41. For i = 0 To UBound(k1) + 1
    
42.     If i <> UBound(k1) + 1 Then s = k1(i) Else s = "合计"
    
43.         With Cells(1, 2 * i + 6).Resize(1, 2)
    
44.              .Value = s
    
45.              .Merge
    
46.              .HorizontalAlignment = -4108
    
47.              .VerticalAlignment = -4108
    
48.         End With
    
49.         Cells(2, 2 * i + 6).Resize(1, 2) = bt
    
50. Next
    
51. col = 2 * d1.Count + 6
    
52. [b3].Resize(d.Count) = Application.Transpose(k)
    
53. crr = [b3].Resize(d.Count)
    
54. [c3].Resize(nn, 3) = crr2
    
55. [a3] = 1: [a4] = 2: [a3:a4].AutoFill [a3].Resize(d.Count)
    
56. m = d.Count + 3
    
57. Cells(m, 2) = "合计"
    
58. For i = 0 To UBound(k)
    
59.     For j = 0 To UBound(k1)
    
60.         If d(k(i)).exists(k1(j)) Then
    
61.             bb = d(k(i))(k1(j))
    
62.             aa = Split(bb, "|")
    
63.             Cells(i + 3, 2 * j + 6) = Val(aa(0))
    
64.             Cells(i + 3, 2 * j + 7) = Val(aa(1))
    
65.             Cells(i + 3, col) = Cells(i + 3, col) + Val(aa(0))
    
66.             Cells(i + 3, col + 1) = Cells(i + 3, col + 1) + Val(aa(1))
    
67.         End If
    
68.     Next
    
69. Next
    
70. For i2 = 6 To col + 1
    
71. Cells(m, i2) = WorksheetFunction.Sum(Range(Cells(3, i2).Address, Cells(m - 1, i2).Address))
    
72. Next
    
73. 
    
74. [a1].CurrentRegion.Borders.LineStyle = 1
    
75. Application.DisplayAlerts = True
    
76. Application.ScreenUpdating = True
    
77. End Sub

复制代码

偷懒，在你代码基础上稍微加了点
实现了你的要求

跳转到最佳答案楼层

chart888

1. Sub aaa()
   
2.     Dim Arr, myPath$, myName$, Arr1, i&, j&, x$, y$
   
3.     Dim d, d1, bt, k, t, k1, aa, s$
   
4.     Dim bb, m&, col&
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set d1 = CreateObject("Scripting.Dictionary")
   
7.     ActiveWindow.DisplayZeros = False
   
8.     Application.DisplayAlerts = False
   
9.     Application.ScreenUpdating = False
   
10.     Sheet1.Activate
    
11.     bt = Array("工作时间", "加班时间")
    
12.     [a3:e5000].Clear
    
13.     [f1:bz5002].Clear
    
14.     Cells.Font.Size = 11
    
15.     myPath = ThisWorkbook.Path & ""
    
16.     myName = Dir(myPath & "*.xls")
    
17.     Do While myName <> ""
    
18.        If InStr(myName, "汇总") = 0 Then
    
19.        With GetObject(myPath & myName)
    
20.            Arr1 = .Sheets(1).[a1].CurrentRegion
    
21.            For i = 3 To UBound(Arr1)
    
22.                x = Arr1(i, 2): y = Split(myName, ".")(0)
    
23.                If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
    
24.                d(x)(y) = d(x)(y) & Arr1(i, 6) & "|" & Arr1(i, 6)
    
25.                d1(y) = ""
    
26.            Next
    
27.            .Close False
    
28.        End With
    
29.        End If
    
30.        myName = Dir
    
31.     Loop
    
32.     k = d.keys: t = d.items: k1 = d1.keys
    
33.     For i = 0 To UBound(k1) + 1
    
34.         If i <> UBound(k1) + 1 Then s = k1(i) Else s = "合计"
    
35.         With Cells(1, 2 * i + 6).Resize(1, 2)
    
36.              .Value = s
    
37.              .Merge
    
38.              .HorizontalAlignment = -4108
    
39.              .VerticalAlignment = -4108
    
40.         End With
    
41.         Cells(2, 2 * i + 6).Resize(1, 2) = bt
    
42.     Next
    
43.     col = 2 * d1.Count + 6
    
44.     [b3].Resize(d.Count) = Application.Transpose(k)
    
45.     [a3] = 1: [a4] = 2: [a3:a4].AutoFill [a3].Resize(d.Count)
    
46.     m = d.Count + 3
    
47.     Cells(m, 2) = "合计"
    
48.     For i = 0 To UBound(k)
    
49.         For j = 0 To UBound(k1)
    
50.             If d(k(i)).exists(k1(j)) Then
    
51.             bb = d(k(i))(k1(j))
    
52.             aa = Split(bb, "|")
    
53.             Cells(i + 3, 2 * j + 6) = Val(aa(0))
    
54.             Cells(i + 3, 2 * j + 7) = Val(aa(1))
    
55.             Cells(i + 3, col) = Cells(i + 3, col) + Val(aa(0))
    
56.             Cells(i + 3, col + 1) = Cells(i + 3, col + 1) + Val(aa(1))
    
57.             End If
    
58.         Next
    
59.     Next
    
60.     Cells(m, 6) = WorksheetFunction.Sum(Range(Cells(3, 6).Address, Cells(m - 1, 6).Address))
    
61.     Cells(m, 6).AutoFill Cells(m, 6).Resize(1, col - 4)
    
62.     [a1].CurrentRegion.Borders.LineStyle = 1
    
63.     Application.DisplayAlerts = True
    
64.     Application.ScreenUpdating = True
    
65. End Sub

复制代码

改了一句

sunche

改了一句，已经很厉害了，我怎么改都没有改出效果来！，老师，能否将C-E列数据也读过来，加班时间也不对，现加班时间中读入的是工作时间。谢谢老师！

yorkchenshunan

1. d(x)(y) = d(x)(y) & Arr1(i, 6) & "|" & Arr1(i, 7)

复制代码

加班时间的问题，改这一条就行了

sunche

谢谢老师，可能中午没有睡觉，脑子是浑的！能否将C-E列数据也读过来？我现在脑子是一片浆糊啊！

chart888

1. Sub aaa()
   
2. Dim Arr, myPath$, myName$, Arr1, i&, j&, x$, y$
   
3. Dim crr2(1 To 10000, 1 To 3)
   
4. Dim d, d1, bt, k, t, k1, aa, s$
   
5. Dim bb, m&, col&
   
6. Set d = CreateObject("Scripting.Dictionary")
   
7. Set d1 = CreateObject("Scripting.Dictionary")
   
8. Application.DisplayAlerts = False
   
9. Application.ScreenUpdating = False
   
10. 
    
11. Sheet1.Activate
    
12. bt = Array("工作时间", "加班时间")
    
13. [a3:e5000].Clear
    
14. [f1:bz5002].Clear
    
15. Cells.Font.Size = 11
    
16. myPath = ThisWorkbook.Path & ""
    
17. myName = Dir(myPath & "*.xls")
    
18. Do While myName <> ""
    
19.     If InStr(myName, "汇总") = 0 Then
    
20.        With GetObject(myPath & myName)
    
21.            Arr1 = .Sheets(1).[a1].CurrentRegion
    
22.            For i = 3 To UBound(Arr1)
    
23.                x = Arr1(i, 2)
    
24.                y = Split(myName, ".")(0)
    
25.                If d.exists(x) = False Then
    
26.                     Set d(x) = CreateObject("Scripting.Dictionary")
    
27.                     nn = nn + 1
    
28.                     crr2(nn, 1) = Arr1(i, 3)
    
29.                     crr2(nn, 2) = Arr1(i, 4)
    
30.                     crr2(nn, 3) = Arr1(i, 5)
    
31.                End If
    
32.                d(x)(y) = d(x)(y) & Arr1(i, 6) & "|" & Arr1(i, 7)
    
33.                d1(y) = ""
    
34.            Next
    
35.            .Close False
    
36.        End With
    
37.     End If
    
38. myName = Dir
    
39. Loop
    
40. k = d.keys: t = d.items: k1 = d1.keys
    
41. For i = 0 To UBound(k1) + 1
    
42.     If i <> UBound(k1) + 1 Then s = k1(i) Else s = "合计"
    
43.         With Cells(1, 2 * i + 6).Resize(1, 2)
    
44.              .Value = s
    
45.              .Merge
    
46.              .HorizontalAlignment = -4108
    
47.              .VerticalAlignment = -4108
    
48.         End With
    
49.         Cells(2, 2 * i + 6).Resize(1, 2) = bt
    
50. Next
    
51. col = 2 * d1.Count + 6
    
52. [b3].Resize(d.Count) = Application.Transpose(k)
    
53. crr = [b3].Resize(d.Count)
    
54. [c3].Resize(nn, 3) = crr2
    
55. [a3] = 1: [a4] = 2: [a3:a4].AutoFill [a3].Resize(d.Count)
    
56. m = d.Count + 3
    
57. Cells(m, 2) = "合计"
    
58. For i = 0 To UBound(k)
    
59.     For j = 0 To UBound(k1)
    
60.         If d(k(i)).exists(k1(j)) Then
    
61.             bb = d(k(i))(k1(j))
    
62.             aa = Split(bb, "|")
    
63.             Cells(i + 3, 2 * j + 6) = Val(aa(0))
    
64.             Cells(i + 3, 2 * j + 7) = Val(aa(1))
    
65.             Cells(i + 3, col) = Cells(i + 3, col) + Val(aa(0))
    
66.             Cells(i + 3, col + 1) = Cells(i + 3, col + 1) + Val(aa(1))
    
67.         End If
    
68.     Next
    
69. Next
    
70. For i2 = 6 To col + 1
    
71. Cells(m, i2) = WorksheetFunction.Sum(Range(Cells(3, i2).Address, Cells(m - 1, i2).Address))
    
72. Next
    
73. 
    
74. [a1].CurrentRegion.Borders.LineStyle = 1
    
75. Application.DisplayAlerts = True
    
76. Application.ScreenUpdating = True
    
77. End Sub

复制代码

偷懒，在你代码基础上稍微加了点
实现了你的要求

sunche

我就想中午能解决它，没睡觉，丢三拉四的。初学代码编写，真的很吃力！非常感谢老师的指导！

chart888

sunche 发表于 2017-6-6 15:00
我就想中午能解决它，没睡觉，丢三拉四的。初学代码编写，真的很吃力！非常感谢老师的指导！

可以的话
给个最佳