[已解决]VBA，如何实现隔行复制

mansiontiger

如何利用VBA将(成品编码)与(原料编码)全部自动汇总；成品编码在偶数，原料编码在奇数行

最佳答案

月排行榜 / 总排行榜

grf1973

2017-6-23 16:21

1. Private Sub Worksheet_Activate()
   
2.    Call tt
   
3. End Sub
   
4.    
   
5. Sub tt()
   
6. Dim arr, brr, crr(), r%, r2%, i%, tr%
   
7.     With Sheets("成品编码")
   
8.         r = .Range("b65536").End(3).Row
   
9.         arr = .Range("a3:e" & r)
   
10.     End With
    
11.     With Sheets("原料编码")
    
12.         r2 = .Range("b65536").End(3).Row
    
13.         brr = .Range("a3:e" & r2)
    
14.     End With
    
15.    
    
16.     On Error Resume Next
    
17.     ReDim crr(1 To Application.Max(UBound(arr), UBound(brr)) * 2, 1 To 5)
    
18.     For i = 1 To UBound(crr) Step 2
    
19.         k = (i + 1) / 2
    
20.         If k <= UBound(arr) Then
    
21.             n = n + 1
    
22.             crr(n, 1) = n
    
23.             For j = 2 To 5
    
24.                 crr(n, j) = arr(k, j)
    
25.             Next
    
26.         End If
    
27.         If k <= UBound(brr) Then
    
28.             n = n + 1
    
29.             crr(n, 1) = n
    
30.             crr(n, 2) = brr(k, 2)
    
31.             crr(n, 4) = brr(k, 3)
    
32.             crr(n, 5) = brr(k, 4)
    
33.         End If
    
34.     Next
    
35.     [a3:e1000] = ""
    
36.     [a3].Resize(UBound(crr), 5) = crr
    
37.     [b3].Resize(UBound(crr)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
38. End Sub

复制代码

跳转到最佳答案楼层

pengyx

编码汇总表是最终效果吗？为什么成品编码在上，原料编码在下呢？哪有什么奇数行和偶数行？？？

mansiontiger

pengyx 发表于 2017-6-22 19:08
编码汇总表是最终效果吗？为什么成品编码在上，原料编码在下呢？哪有什么奇数行和偶数行？？？

不是最终效果；公司有套表格，需要在汇总表里做上下两行直观对比，
我的理解是想通过奇偶来实现，弄了几天都没实现了，现在是通过链接来的

grf1973

1. Private Sub Worksheet_Activate()
   
2.    Call tt
   
3. End Sub
   
4.    
   
5. Sub tt()
   
6. Dim arr, brr, crr(), r%, r2%, i%, tr%
   
7.     With Sheets("成品编码")
   
8.         r = .Range("b65536").End(3).Row
   
9.         arr = .Range("a3:e" & r)
   
10.     End With
    
11.     With Sheets("原料编码")
    
12.         r2 = .Range("b65536").End(3).Row
    
13.         brr = .Range("a3:e" & r2)
    
14.     End With
    
15.    
    
16.     On Error Resume Next
    
17.     ReDim crr(1 To Application.Max(UBound(arr), UBound(brr)) * 2, 1 To 5)
    
18.     For i = 1 To UBound(crr) Step 2
    
19.         k = (i + 1) / 2
    
20.         If k <= UBound(arr) Then
    
21.             n = n + 1
    
22.             crr(n, 1) = n
    
23.             For j = 2 To 5
    
24.                 crr(n, j) = arr(k, j)
    
25.             Next
    
26.         End If
    
27.         If k <= UBound(brr) Then
    
28.             n = n + 1
    
29.             crr(n, 1) = n
    
30.             crr(n, 2) = brr(k, 2)
    
31.             crr(n, 4) = brr(k, 3)
    
32.             crr(n, 5) = brr(k, 4)
    
33.         End If
    
34.     Next
    
35.     [a3:e1000] = ""
    
36.     [a3].Resize(UBound(crr), 5) = crr
    
37.     [b3].Resize(UBound(crr)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
38. End Sub

复制代码

mansiontiger

感谢老师！太完美了。谢谢！