[已解决]用VBA提取隔1到隔12的值

superle! · 发表于 2014-6-28 21:14

本帖最后由 superle! 于 2014-6-29 15:57 编辑

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

最佳答案

月排行榜 / 总排行榜

dsmch

2014-6-29 14:04

Sub Macro1()
On Error Resume Next
Dim arr, brr(1 To 60000, 1 To 12)
arr = Range("j2:j" & Cells(Rows.Count, "j").End(xlUp).Row)
m = 0
For i = 1 To 12
s = UBound(arr) + 1: n = 0
Do Until s < 1
s = s - i - 1
Loop
Do Until s > UBound(arr)
s = s + i + 1
n = n + 1
brr(n, i) = arr(s, 1)
Loop
If n > m Then m = n
Next
[ab2:am5000].ClearContents
Range("ab2").Resize(m, 12) = brr
End Sub

复制代码

跳转到最佳答案楼层

dsmch · 发表于 2014-6-29 09:08

说明与示意结果前后矛盾，看不出模拟结果与j33有什么关系？

superle! · 发表于 2014-6-29 09:56

dsmch 发表于 2014-6-29 09:08
说明与示意结果前后矛盾，看不出模拟结果与j33有什么关系？

恩。J33是无关的，我写错了，是J37为准。

dsmch · 发表于 2014-6-29 10:41

猜一下…………

Sub Macro1()
On Error Resume Next
Dim arr, brr(1 To 60000, 1 To 12)
arr = Range("j2:j" & Cells(Rows.Count, "j").End(xlUp).Row)
m = 0
For i = 1 To 12
s = 0: n = 0
Do Until s > UBound(arr)
s = s + i + 1
n = n + 1
brr(n, i) = arr(s, 1)
Loop
If n > m Then m = n
Next
Range("ab2").Resize(m, 12) = brr
End Sub

复制代码

superle! · 发表于 2014-6-29 10:47

dsmch 发表于 2014-6-29 10:41
猜一下…………

不对，如果J33加个值，以以J34为准的往上找。找到最上面一个然后第二行开始填充。

superle! · 发表于 2014-6-29 11:06

dsmch 发表于 2014-6-29 10:41
猜一下…………

J37加个值，模拟的结果就是这样的。

dsmch · 发表于 2014-6-29 11:22

Sub Macro1()
On Error Resume Next
Dim arr, brr(1 To 60000, 1 To 12)
arr = Range("j2:j" & Cells(Rows.Count, "j").End(xlUp).Row)
m = 0
For i = 1 To 12
s = UBound(arr) + 1: n = 0
Do Until s < 1
s = s - i - 1
Loop
Do Until s > UBound(arr)
s = s + i + 1
n = n + 1
brr(n, i) = arr(s, 1)
Loop
If n > m Then m = n
Next
Range("ab2").Resize(m, 12) = brr
End Sub

复制代码

superle! · 发表于 2014-6-29 12:16

dsmch 发表于 2014-6-29 11:22

结果已经对了。加一个功能，就是AB:AM列填充执行时先清除这几个列数据。

superle! · 发表于 2014-6-29 12:48

dsmch 发表于 2014-6-29 11:22

这倒难倒我了。[ab2:am5000].ClearContents 放哪里？给个完整的代码吧。

dsmch · 发表于 2014-6-29 14:04

Sub Macro1()
On Error Resume Next
Dim arr, brr(1 To 60000, 1 To 12)
arr = Range("j2:j" & Cells(Rows.Count, "j").End(xlUp).Row)
m = 0
For i = 1 To 12
s = UBound(arr) + 1: n = 0
Do Until s < 1
s = s - i - 1
Loop
Do Until s > UBound(arr)
s = s + i + 1
n = n + 1
brr(n, i) = arr(s, 1)
Loop
If n > m Then m = n
Next
[ab2:am5000].ClearContents
Range("ab2").Resize(m, 12) = brr
End Sub

复制代码

		自动登录	找回密码
密码			注册

[已解决]用VBA提取隔1到隔12的值

点评

点评