[已解决]宏代码：如何改为数组形式

lijian8003

下列2个宏代码，如何改为数组形式？

1. Sub 问题1_1()
   
2. Application.ScreenUpdating = False
   
3. For j = 2 To 11
   
4. For i = 5 To 104
   
5. If Cells(i, j) = Cells(1, 1) Then Cells(1, j) = Cells(i, 1)
   
6. Next
   
7. Next
   
8. Application.ScreenUpdating = True
   
9. End Sub
   
10. 
    
11. Sub 问题2_1()
    
12. Application.ScreenUpdating = False
    
13. For j = 2 To 11
    
14. For i = 5 To 104
    
15. If Cells(i, 1) = Cells(1, j) Then
    
16. Sheet2.Cells(1, 2 + n) = Cells(i, j)
    
17. n = n + 1
    
18. End If
    
19. Next
    
20. Next
    
21. Application.ScreenUpdating = True
    
22. End Sub

复制代码

最佳答案

月排行榜 / 总排行榜

dsmch

2014-12-6 20:10

1. Sub Macro1()
   
2. Dim arr, brr(1 To 1, 1 To 200), i&, j%
   
3. arr = Range("a5").CurrentRegion
   
4. x = Cells(1, 1)
   
5. For i = 1 To UBound(arr)
   
6.     For j = 2 To UBound(arr, 2)
   
7.         If arr(i, j) = x Then s = s + 1: brr(1, s) = arr(i, 1)
   
8.     Next
   
9. Next
   
10. Range("b1").Resize(1, s) = brr
    
11. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr(1 To 1, 1 To 200), i&, j%
   
3. arr = Range("a5").CurrentRegion
   
4. x = Cells(1, 1)
   
5. For i = 1 To UBound(arr)
   
6.     For j = 2 To UBound(arr, 2)
   
7.         If arr(i, j) = x Then s = s + 1: brr(1, s) = arr(i, 1)
   
8.     Next
   
9. Next
   
10. Range("b1").Resize(1, s) = brr
    
11. End Sub

复制代码

dsmch

1. Sub Macro2()
   
2. Dim arr, brr, j%
   
3. arr = Range("a5").CurrentRegion
   
4. brr = Range("a1").CurrentRegion
   
5. brr(1, 1) = ""
   
6. For j = 2 To UBound(brr, 2)
   
7.     brr(1, j) = arr(brr(1, j), j)
   
8. Next
   
9. Sheet2.Range("a1").Resize(1, UBound(brr, 2)) = brr
   
10. End Sub

复制代码

lijian8003

dsmch 发表于 2014-12-6 20:19

您的代码运算结果有误，不知道错在哪？

自己改写了一下，恳望您给予优化：
Sub zz()  ' 问题1
    Application.ScreenUpdating = False
    arr = [a5:k104]
    [b1:k1] = ""
    brr = [a1:k1]
    For j = 2 To UBound(arr, 2)
        For i = 1 To UBound(arr)
            If arr(i, j) = brr(1, 1) Then brr(1, j) = arr(i, 1)
        Next
    Next
    [a1].Resize(UBound(brr), UBound(brr, 2)) = brr
    Application.ScreenUpdating = True
End Sub

Sub zzz() '问题2
    Application.ScreenUpdating = False
    arr = [a5:k104]
    a = [a1:k1]
    For j = 2 To UBound(arr, 2)
        For i = 1 To UBound(arr)
            If arr(i, 1) = a(1, j) Then
                Sheet2.Cells(1, 2 + n) = arr(i, j)
                n = n + 1
            End If
        Next
    Next
    Application.ScreenUpdating = True
End Sub

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, i&, j%
   
3. arr = Range("a5").CurrentRegion
   
4. ReDim brr(1 To 1, 1 To UBound(arr, 2) - 1)
   
5. x = Cells(1, 1)
   
6. For i = 1 To UBound(arr)
   
7.     For j = 2 To UBound(arr, 2)
   
8.         If arr(i, j) = x Then brr(1, j - 1) = arr(i, 1)
   
9.     Next
   
10. Next
    
11. Range("b1").Resize(1, UBound(brr, 2)) = brr
    
12. End Sub

复制代码

lijian8003

dsmch 发表于 2014-12-6 21:27

感谢您的帮助！
实际运用中，需要增添第2行、第3行数据，自己试着将Macro1代码修改了，但是Macro2的代码不知道如何修改。恳望继续得到您的帮助！

dsmch

两段代码可以合并成一段

1. Sub Macro1()
   
2. Dim arr, brr, i&, j%, k%
   
3. arr = Range("a5").CurrentRegion
   
4. ReDim brr(1 To 3, 1 To UBound(arr, 2) - 1)
   
5. For k = 1 To 3
   
6.     x = Cells(k, 1)
   
7.     For i = 1 To UBound(arr)
   
8.         For j = 2 To UBound(arr, 2)
   
9.             If arr(i, j) = x Then brr(k, j - 1) = arr(i, 1)
   
10.         Next
    
11.     Next
    
12. Next
    
13. Range("b1").Resize(3, UBound(brr, 2)) = brr
    
14. For i = 1 To UBound(brr)
    
15.     For j = 1 To UBound(brr, 2)
    
16.         brr(i, j) = arr(brr(i, j), j + 1)
    
17.     Next
    
18. Next
    
19. Sheet2.Range("b1").Resize(3, UBound(brr, 2)) = brr
    
20. End Sub

复制代码

lijian8003

dsmch 发表于 2014-12-9 13:45
两段代码可以合并成一段

ReDim brr(1 To 3, 1 To UBound(arr, 2) - 1)
经过测试，上述语句出错。恳望帮助。

dsmch

附件，自己测试……

lijian8003

dsmch 发表于 2014-12-9 14:10
附件，自己测试……

感谢！