[已解决]急求解决的代码问题

gaogege852

在做一个表册汇总时，执行命令出错，点调试发现一行代码出黄色，但如果把分表中的记录字数减少又能正常汇总，但表中的数字又不能删减，应该如何改代码？具体请大家测试附件。

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-3-29 21:36

1. Sub 汇总()
   
2.     Dim file$, path$
   
3.     Dim wb As Workbook
   
4.     Dim arr(1 To 5000, 1 To 3), lCount&
   
5.     Dim arrPos, j As Byte
   
6.     Application.ScreenUpdating = False
   
7.     arrPos = Array("a3", "b3")
   
8.     path = ThisWorkbook.path & Application.PathSeparator
   
9.     file = Dir(path & "*.xls", vbNormal + vbDirectory)
   
10. 
    
11.     Do While Len(file) > 0
    
12.         If file <> ThisWorkbook.Name Then
    
13.             lCount = lCount + 1
    
14.                Set wb = GetObject(path & file)
    
15.             With wb.Worksheets("sheet1")
    
16.                 For j = 1 To UBound(arr, 2) - 1
    
17.                     arr(lCount, j) = "'" & .Range(arrPos(j - 1))
    
18.                 Next
    
19.                 arr(lCount, 3) = .Range("c2") & ":" & .Range("c3") & "," & _
    
20.                                  .Range("d2") & ":" & .Range("d3") & "," & _
    
21.                                  .Range("a4") & ":" & .Range("b4").Text & "," & _
    
22.                                  .Range("c4") & ":" & .Range("d4") & "," & _
    
23.                                  .Range("a5") & ":" & .Range("b5") & "," & _
    
24.                                  .Range("a6") & ":" & .Range("b6") & "," & _
    
25.                                  .Range("a7") & ":" & .Range("b7") & "," & _
    
26.                                  .Range("a8") & ":" & .Range("b8") & "."
    
27.             End With
    
28.             wb.Close False
    
29.         End If
    
30.         file = Dir
    
31.     Loop
    
32.     Range("a" & Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(lCount, 3) = arr
    
33.     Range("a1").CurrentRegion.Borders.LineStyle = xlContinuous
    
34.     Application.ScreenUpdating = True
    
35.     MsgBox "汇总完成"
    
36. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

不是说了嘛，你所数组换成固定的就行了。因为转置的时候函数限制。

hwc2ycy

1. Sub 汇总()
   
2.     Dim file$, path$
   
3.     Dim wb As Workbook
   
4.     Dim arr(1 To 5000, 1 To 3), lCount&
   
5.     Dim arrPos, j As Byte
   
6.     Application.ScreenUpdating = False
   
7.     arrPos = Array("a3", "b3")
   
8.     path = ThisWorkbook.path & Application.PathSeparator
   
9.     file = Dir(path & "*.xls", vbNormal + vbDirectory)
   
10. 
    
11.     Do While Len(file) > 0
    
12.         If file <> ThisWorkbook.Name Then
    
13.             lCount = lCount + 1
    
14.                Set wb = GetObject(path & file)
    
15.             With wb.Worksheets("sheet1")
    
16.                 For j = 1 To UBound(arr, 2) - 1
    
17.                     arr(lCount, j) = "'" & .Range(arrPos(j - 1))
    
18.                 Next
    
19.                 arr(lCount, 3) = .Range("c2") & ":" & .Range("c3") & "," & _
    
20.                                  .Range("d2") & ":" & .Range("d3") & "," & _
    
21.                                  .Range("a4") & ":" & .Range("b4").Text & "," & _
    
22.                                  .Range("c4") & ":" & .Range("d4") & "," & _
    
23.                                  .Range("a5") & ":" & .Range("b5") & "," & _
    
24.                                  .Range("a6") & ":" & .Range("b6") & "," & _
    
25.                                  .Range("a7") & ":" & .Range("b7") & "," & _
    
26.                                  .Range("a8") & ":" & .Range("b8") & "."
    
27.             End With
    
28.             wb.Close False
    
29.         End If
    
30.         file = Dir
    
31.     Loop
    
32.     Range("a" & Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(lCount, 3) = arr
    
33.     Range("a1").CurrentRegion.Borders.LineStyle = xlContinuous
    
34.     Application.ScreenUpdating = True
    
35.     MsgBox "汇总完成"
    
36. End Sub

复制代码

hwc2ycy

测试你来，有问题再说。

gaogege852

hwc2ycy 发表于 2013-3-29 21:33
不是说了嘛，你所数组换成固定的就行了。因为转置的时候函数限制。

其实非常感谢你帮我写的这个代码，但我实在是读不懂，所以你说的数组换成固定应该如何操作还真不知道啊，麻烦再帮一下

gaogege852

hwc2ycy 发表于 2013-3-29 21:36

非常感谢，现在这个不出问题了

gaogege852

gaogege852 发表于 2013-3-29 21:39
非常感谢，现在这个不出问题了

麻烦你再帮我看一下我提的另一个表册汇总问题，谢谢