求老司机带路，求曲线上升的数据提取到指定的列的VBA代码。谢谢！

心云德乐

曲线提取数据.rar (40.72 KB, 下载次数: 3)

2019-9-8 23:10 上传

点击文件名下载附件

wodewan

1. Sub test()
   
2. Dim i&, j&, x&, y&, arr, brr()
   
3. arr = Range("A1").CurrentRegion
   
4. ReDim Preserve brr(1 To UBound(arr))
   
5.     j = 1
   
6.     For i = UBound(arr) To 1 Step -1
   
7.         y = y + 1
   
8.         j = x + j
   
9.         brr(y) = arr(i, j)
   
10.         If j = 7 Then x = -1
    
11.         If j = 1 Then x = 1
    
12.     Next
    
13. Range("j1").EntireColumn.ClearContents
    
14. Range("j1").Resize(UBound(brr)) = Application.WorksheetFunction.Transpose(brr)
    
15. End Sub

复制代码

心云德乐

wodewan 发表于 2019-9-9 09:18

谢谢！评分我想评+5分，可评分系统不会调，只好评+2分，显示不得重复评分，我也醉啦！

心云德乐

wodewan 发表于 2019-9-9 09:18

为什么我下载您的RAR压缩包时不成功，显示《无标题》。

心云德乐

wodewan 发表于 2019-9-9 09:18

C:\Users\Dell\Desktop\2019年8月7日VBA编程事件\曲线提取数据
C:\Users\Dell\Desktop\2019年8月7日VBA编程事件\曲线提取数据

wodewan

心云德乐 发表于 2019-9-10 12:28
C:%users\Dell\Desktop\2019年8月7日VBA编程事件\曲线提取数据

我刚下载下来没啥问题，换了个名再传一个，你试试。

心云德乐

wodewan 发表于 2019-9-10 12:31
我刚下载下来没啥问题，换了个名再传一个，你试试。

首先谢谢您的帮助，我复制你上传的代码试了n次，不成功！

wodewan

你附件还下不了吗？原来不是写在模块里的，写在sheet1里，我刚刚放标准模块也没问题啊

wodewan

心云德乐 发表于 2019-9-11 21:07
首先谢谢您的帮助，我复制你上传的代码试了n次，不成功！

这是刚刚试的，放SHEET1,放标准模块都没啥问题，实在不行，你把你有问题的文件传上来，我看看，你又下不了附件，我也是没办法了。

wodewan

心云德乐 发表于 2019-9-11 21:07
首先谢谢您的帮助，我复制你上传的代码试了n次，不成功！

大概知道怎么回事了，你是不是数据表前几行行是空的？把前面的空行删掉，因为代码用的RANGE("A1").CURRENTREGION,保证第一行有数据。