[已解决]求优化下代码

zhengfaq

Sub dd()

   c = Sheets("用料表").Range("b655306").End(xlUp).Row
   n = 1
For a = 2 To 18

    For b = 2 To c
      If Sheets("sheet1").Cells(a, 4) = Sheets("用料表").Cells(b, 2) Then
            n = n + 1
        For d = 1 To 5

          Sheets("sheet2").Cells(n, d) = Sheets("用料表").Cells(b, d)
         Next
             f = 1
            For e = 6 To 7
               Sheets("sheet2").Cells(n, e) = Sheets("sheet1").Cells(a, f)
                f = f + 1
             Next
           End If
    Next
  Next
  End Sub
我是新手，这个代码数据量大的时候执行起来很慢。我想有更高效的代码，求帮忙！

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-8-4 09:18

1. Sub aaa()
   
2. Dim arr, brr, crr(1 To 10000, 1 To 7), drr, i&, j&, k&, d As Object, r&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheets(2).[a1].CurrentRegion
   
5. For i = 2 To UBound(arr)
   
6.   d(arr(i, 2)) = d(arr(i, 2)) & "," & i
   
7. Next i
   
8. brr = Sheets(1).[a1].CurrentRegion
   
9. For i = 2 To UBound(brr)
   
10.   drr = Split(d(brr(i, 4)), ",")
    
11.   For k = 1 To UBound(drr)
    
12.     r = r + 1
    
13.     For j = 1 To 5
    
14.       crr(r, j) = arr(drr(k), j)
    
15.     Next j
    
16.     crr(r, 6) = brr(i, 1)
    
17.     crr(r, 7) = brr(i, 2)
    
18.   Next k
    
19. Next i
    
20. Sheets(3).[a1].CurrentRegion.Offset(1).ClearContents
    
21. Sheets(3).[a2].Resize(r, 7) = crr
    
22. End Sub

复制代码

跳转到最佳答案楼层

idnoidno

使用數組執行取代儲存格操作

1. <div class="blockcode"><blockquote>Option Explicit
   
2. Sub t1()
   
3. Dim ar, br, cr
   
4. ar = Sheets("用料表").UsedRange
   
5. br = Sheets(1).UsedRange
   
6. cr = Sheets(2).UsedRange
   
7. 
   
8. n = 1
   
9. For a = 2 To 18
   
10. 
    
11.     For b = 2 To UBound(ar)
    
12.       If br(a, 4) = ar(b, 2) Then
    
13.             n = n + 1
    
14.         For d = 1 To 5
    
15. 
    
16.           cr(n, d) = ar(b, d)
    
17.          Next
    
18.              f = 1
    
19.             For e = 6 To 7
    
20.                cr(n, e) = br(a, f)
    
21.                 f = f + 1
    
22.              Next
    
23.            End If
    
24.     Next
    
25.   Next
    
26. 
    
27. End Sub
    

复制代码

zhengfaq

idnoidno 发表于 2017-8-4 06:19
使用數組執行取代儲存格操作

代码执行后，cr(n, e) = br(a, f)   出现下标越界。代码执行后的结果是输出到Sheet2表格的。

上清宫主

代码效率低
楼主代码目的是用“用料表中整机型号”和“seet1中的规格型号”比较，只要两者相同，就把用料表的该行和sheet1的日期数量添加进sheet2
“用料表中整机型号”和“seet1中的规格型号”均有很多重复的，他也要重复添加？

zhengfaq

上清宫主 发表于 2017-8-4 09:01
代码效率低
楼主代码目的是用“用料表中整机型号”和“seet1中的规格型号”比较，只要两者相同，就把用料 ...

是这样的，因为每天都有生产领用，所以规格也会有重复。

大灰狼1976

1. Sub aaa()
   
2. Dim arr, brr, crr(1 To 10000, 1 To 7), drr, i&, j&, k&, d As Object, r&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheets(2).[a1].CurrentRegion
   
5. For i = 2 To UBound(arr)
   
6.   d(arr(i, 2)) = d(arr(i, 2)) & "," & i
   
7. Next i
   
8. brr = Sheets(1).[a1].CurrentRegion
   
9. For i = 2 To UBound(brr)
   
10.   drr = Split(d(brr(i, 4)), ",")
    
11.   For k = 1 To UBound(drr)
    
12.     r = r + 1
    
13.     For j = 1 To 5
    
14.       crr(r, j) = arr(drr(k), j)
    
15.     Next j
    
16.     crr(r, 6) = brr(i, 1)
    
17.     crr(r, 7) = brr(i, 2)
    
18.   Next k
    
19. Next i
    
20. Sheets(3).[a1].CurrentRegion.Offset(1).ClearContents
    
21. Sheets(3).[a2].Resize(r, 7) = crr
    
22. End Sub

复制代码

idnoidno

一早搶頭香，不過能力不夠，按照須求改，不過高手出手重寫了，我也可以來學習一下
感謝實習版主的解圍

zhengfaq

idnoidno 发表于 2017-8-4 10:25
一早搶頭香，不過能力不夠，按照須求改，不過高手出手重寫了，我也可以來學習一下
感謝實習版主的解圍^: ...

还是要感谢你的解答，我也要继续学习。

zhengfaq

大灰狼1976 发表于 2017-8-4 09:18

太厉害了，执行的速度超快。几十万行的数据很快就完成了！