[已解决]VBA 双重循环代码优化，如何能够快速运行

弘仁

各位前辈：

               请帮忙优化下代码，谢谢！


               Sub 格式转换()Dim col_cnt, row_cnt As Integer
Dim qty As Double
On Error GoTo err_processing

row_cnt = 3
While ThisWorkbook.Sheets("中转").Cells(row_cnt, 1) <> ""
    row_cnt = row_cnt + 1
Wend
row_cnt = row_cnt - 1
Debug.Print col_cnt, row_cnt
ThisWorkbook.Sheets("输出").Cells(1, 1) = "客户"
ThisWorkbook.Sheets("输出").Cells(1, 2) = "零件号"
ThisWorkbook.Sheets("输出").Cells(1, 3) = "日期"
ThisWorkbook.Sheets("输出").Cells(1, 4) = "数量"

k = 2
For i = 3 To row_cnt
    For j = 3 To col_cnt
        qty = ThisWorkbook.Sheets("中转").Cells(i, j)
         If ThisWorkbook.Sheets("中转").Cells(i, 2) = 0 Then
         Exit For
         End If
'        If qty = 0 Then
'            GoTo next_j
'        End If

        ThisWorkbook.Sheets("输出").Cells(k, 1) = UCase(ThisWorkbook.Sheets("中转").Cells(i, 1))
        ThisWorkbook.Sheets("输出").Cells(k, 2) = UCase(ThisWorkbook.Sheets("中转").Cells(i, 2))
        ThisWorkbook.Sheets("输出").Cells(k, 3) = ThisWorkbook.Sheets("中转").Cells(2, j)
        ThisWorkbook.Sheets("输出").Cells(k, 4) = qty
        k = k + 1

next_j:
    Next j
Next i
ThisWorkbook.Sheets("输出").Select
Columns("C:C").Select
Selection.NumberFormatLocal = "yyyymmdd"
Cells.Select
Selection.ColumnWidth = 16

GoTo sub_end

sub_end:
End Sub

最佳答案

月排行榜 / 总排行榜

dsmch

2015-8-22 05:45

Sub Macro1()
Dim arr, brr, i&, j&, k%, s&
arr = Sheet1.Range("a1").CurrentRegion
ReDim brr(1 To 60000, 1 To 4)
For i = 3 To UBound(arr)
    For j = 3 To UBound(arr, 2)
        If arr(i, j) > 0 Then
            n = arr(2, j)
            x = arr(i, j) \ n: y = arr(i, j) Mod n
            For k = 0 To n - 1   
                s = s + 1
                brr(s, 1) = arr(i, 1)
                brr(s, 2) = arr(i, 2)
                brr(s, 3) = DateAdd("d", k, arr(1, j))
                brr(s, 4) = IIf(k = 0, x + y, x)
            Next
        End If
    Next
Next
Sheet2.Activate
ActiveSheet.UsedRange.ClearContents
[a1:d1] = Array("客户", "零件号", "日期", "数量")
Range("a2").Resize(s, 4) = brr
End Sub

跳转到最佳答案楼层

avel

用数组存储数据 进行循环比较后再以数组的形式输出。

速度绝对快。

弘仁

avel 发表于 2015-8-11 20:13
用数组存储数据 进行循环比较后再以数组的形式输出。

速度绝对快。

前辈：

        能够帮忙优化下代码吗？我数组不会也，谢谢了！

弘仁

有大师帮忙指点下吗？

弘仁

顶个贴！

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, i&, j&, k%, s&
   
3. arr = Sheet1.Range("a1").CurrentRegion
   
4. ReDim brr(1 To 60000, 1 To 4)
   
5. For i = 3 To UBound(arr)
   
6.     For j = 3 To UBound(arr, 2)
   
7.         If arr(i, j) > 0 Then
   
8.             x = arr(i, j) \ 5: y = arr(i, j) Mod 5
   
9.             For k = 0 To 4
   
10.                 s = s + 1
    
11.                 brr(s, 1) = arr(i, 1)
    
12.                 brr(s, 2) = arr(i, 2)
    
13.                 brr(s, 3) = DateAdd("d", k, arr(1, j))
    
14.                 brr(s, 4) = IIf(k = 0, x + y, x)
    
15.             Next
    
16.         End If
    
17.     Next
    
18. Next
    
19. Sheet2.Activate
    
20. ActiveSheet.UsedRange.ClearContents
    
21. [a1:d1] = Array("客户", "零件号", "日期", "数量")
    
22. Range("a2").Resize(s, 4) = brr
    
23. End Sub

复制代码

弘仁

dsmch 发表于 2015-8-11 22:47

前辈：

        当我数据行比较多的时候，报错“下标越界”，请帮忙优化下，辛苦了！

弘仁

dsmch 发表于 2015-8-11 22:47

师傅：

        有没有什么书籍推荐下，VBA入门和组数应用这方面的书籍推荐啊，我这基础太弱了，想好好学习下！

上清宫主

弘仁 发表于 2015-8-12 21:16
前辈：

        当我数据行比较多的时候，报错“下标越界”，请帮忙优化下，辛苦了！

你一个数据要变成那么多行，就这个量，结果表已经20多万行发，当然会超过数组定义的65536。
分段写入吧：
Sub Macro2()
Sheet2.Activate
ActiveSheet.UsedRange.ClearContents
[a1:d1] = Array("客户", "零件号", "日期", "数量")
Dim arr, brr(1 To 65536, 1 To 4), i&, j&, k%, s&
arr = Sheet1.Range("a1").CurrentRegion
For i = 3 To UBound(arr)
    For j = 3 To UBound(arr, 2)
        If arr(i, j) > 0 Then
            x = arr(i, j) \ 5: y = arr(i, j) Mod 5
            For k = 0 To 4
                s = s + 1
                If s > 65536 Then
                   Sheet2.Cells(Rows.Count, 1).End(3)(2).Resize(s - 1, 4) = brr
                   Erase brr
                   s = 1
                End If
                brr(s, 1) = arr(i, 1)
                brr(s, 2) = arr(i, 2)
                brr(s, 3) = DateAdd("d", k, arr(1, j))
                brr(s, 4) = IIf(k = 0, x + y, x)
            Next
        End If
    Next
Next
If s > 0 Then
   Sheet2.Cells(Rows.Count, 1).End(3)(2).Resize(s - 1, 4) = brr
End If
End Sub

如果数据再多，结果表超过了1048576行还要报错哈。解决办法是需要你给出规则

弘仁

上清宫主 发表于 2015-8-13 09:09
你一个数据要变成那么多行，就这个量，结果表已经20多万行发，当然会超过数组定义的65536。
分段写入吧： ...

前辈：

         这个数组的行数，能不能先计算sheet1里面数据转换需要生成的行数，再将这个数值引入到数值行数里面

         老师，请否推荐一些书籍啊，我这块知识很薄弱，想好好学习下，谢谢老师的指导！