[已解决]用VBA提取隔0到隔12的值排列

superle!

J列为数据源从J2开始到J很多行，黄色背景为VBA实现的填充
以J36为准，J列最下面有值的为准（红色背景），下面的值可能会增加或是减少。可能会增加到5千行，所以要考虑。
从AB2的值开始填充为隔0，取J列的J2,J3,J4,J5,J6,J7,J8.。。。。J35的值。
从AC2的值开始填充为隔1，取J列的J2,J4,J6,J8,J10,J12,J14。。。J34的值。
AD2的值开始填充为隔2的值。取J列的J5,J9,J13的值。
注意的是，一定要从J36的值为准，J列往上取隔1到隔12的值，然后把取到的最后一个值填充到第二行1个。
执行VBA按钮时不清除黄色左右列的数据 。
黄色背景已经都模拟出来了。

最佳答案

月排行榜 / 总排行榜

芐雨

2015-1-21 17:34

superle! 发表于 2015-1-21 17:25
我说得可能有点误解了。
AB:AN列是随着J列的增加数值也会增加的，不是最多在35行内的。

已按要求修改，你测试下

1. Sub t()
   
2. Dim i&, j&, Lr&, n&, m&
   
3. Dim arr, brr
   
4. arr = Range("J2:J" & Cells(Rows.Count, "J").End(3).Row - 1)
   
5. Lr = UBound(arr) '数组数
   
6. ReDim brr(1 To Lr, 1 To 13)
   
7. For j = 1 To 13 '隔0到隔12
   
8. n = Lr \ j '计算数值的个数
   
9. m = Lr + 1 - n * j '第一个数值的位置
   
10. For i = 1 To n
    
11. brr(i, j) = arr(m + (i - 1) * j, 1) '(i-1)*j隔数
    
12. Next
    
13. Next
    
14. With Range("AB2")
    
15. .Resize(Rows.Count - 1, 13).ClearContents '清除内容
    
16. .Resize(UBound(brr), 13) = brr '赋值
    
17. End With
    
18. End Sub

复制代码

跳转到最佳答案楼层

芐雨

1. Sub t()
   
2.     Dim i&, j&, Lr&, n&, m&
   
3.     Dim arr, brr(1 To 34, 1 To 13)
   
4.     arr = Range("J2:J" & Cells(Rows.Count, "J").End(3).Row - 1)
   
5.     Lr = UBound(arr)              '数组数
   
6.     For j = 1 To 13               '隔0到隔12
   
7.         n = Lr \ j                '计算数值的个数
   
8.         If n > 34 Then n = 34     '个数大于34，n=34
   
9.         m = Lr + 1 - n * j        '第一个数值的位置
   
10.         For i = 1 To n
    
11.             brr(i, j) = arr(m + (i - 1) * j, 1)  '(i-1)*j隔数
    
12.         Next
    
13.     Next
    
14.     Range("AB2:AN35") = brr
    
15. End Sub
    

复制代码

superle!

芐雨 发表于 2015-1-21 16:53

我说得可能有点误解了。
AB:AN列是随着J列的增加数值也会增加的，不是最多在35行内的。

芐雨

superle! 发表于 2015-1-21 17:25
我说得可能有点误解了。
AB:AN列是随着J列的增加数值也会增加的，不是最多在35行内的。

已按要求修改，你测试下

1. Sub t()
   
2. Dim i&, j&, Lr&, n&, m&
   
3. Dim arr, brr
   
4. arr = Range("J2:J" & Cells(Rows.Count, "J").End(3).Row - 1)
   
5. Lr = UBound(arr) '数组数
   
6. ReDim brr(1 To Lr, 1 To 13)
   
7. For j = 1 To 13 '隔0到隔12
   
8. n = Lr \ j '计算数值的个数
   
9. m = Lr + 1 - n * j '第一个数值的位置
   
10. For i = 1 To n
    
11. brr(i, j) = arr(m + (i - 1) * j, 1) '(i-1)*j隔数
    
12. Next
    
13. Next
    
14. With Range("AB2")
    
15. .Resize(Rows.Count - 1, 13).ClearContents '清除内容
    
16. .Resize(UBound(brr), 13) = brr '赋值
    
17. End With
    
18. End Sub

复制代码

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, Myr&, Arr1, xg(1 To 5000), j&, n&, m&
   
3. Application.ScreenUpdating = False
   
4. Sheet1.Activate
   
5. [ab2:an5000].ClearContents
   
6. Myr = Cells(Rows.Count, 10).End(xlUp).Row
   
7. Arr = Range("j1:j" & Myr)
   
8. Arr1 = [j2].Resize(UBound(Arr) - 2, 1)
   
9. [ab2].Resize(UBound(Arr1), 1) = Arr1
   
10. For j = 1 To 12
    
11.     n = 0: Erase xg
    
12.     For i = 36 To 2 Step -j
    
13.         If i <> 36 Then
    
14.             n = n + 1
    
15.             xg(n) = Arr(i, 1)
    
16.         End If
    
17.     Next
    
18.     m = 1
    
19.     For i = n To 1 Step -1
    
20.         m = m + 1
    
21.         Cells(m, j + 27) = xg(i)
    
22.     Next
    
23. Next
    
24. Application.ScreenUpdating = True
    
25. End Sub
    

复制代码