[已解决]如何用代码分离数据？

dfshm

附件 分离数据附件.rar (12.06 KB, 下载次数: 4)

2013-5-15 19:04 上传

点击文件名下载附件

谢谢！

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-5-15 19:42

分离数据附件.rar (16.13 KB, 下载次数: 4)

2013-5-15 19:42 上传

点击文件名下载附件

跳转到最佳答案楼层

hwc2ycy

1. Sub 提取数据()
   
2.     Dim lLastrow&, arr1, arr(), i&, j&
   
3.     lLastrow = Cells(Rows.Count, 1).End(xlUp).Row
   
4.     arr1 = Range("a1:a" & lLastrow)
   
5.     ReDim arr(1 To (lLastrow + 1) \ 7, 1 To 1)
   
6.     For i = 6 To lLastrow Step 7
   
7.         j = j + 1
   
8.         arr(j, 1) = arr1(i, 1)
   
9.     Next
   
10.     Range("d1").Resize(j).Value = arr
    
11. End Sub

复制代码

hwc2ycy

1. Sub 提取数据()
   
2.     '最后一行行号，源数组，结果数组，循环用变量
   
3.     Dim lLastrow&, arr1, arr(), i&, j&
   
4.    
   
5.     '取A列最后一行数据所在行号
   
6.     lLastrow = Cells(Rows.Count, 1).End(xlUp).Row
   
7.    
   
8.     '读取数据
   
9.     arr1 = Range("a1:a" & lLastrow)
   
10.    
    
11.     '结果数组扩维，用的动态数组，因为是6行一间隔，所以最后行加1，再整除7，得到个数
    
12.     ReDim arr(1 To (lLastrow + 1) \ 7, 1 To 1)
    
13.    
    
14.     '第6行开始循环，步长为7
    
15.     For i = 6 To lLastrow Step 7
    
16.         '个数，指标结果数组一维
    
17.         j = j + 1
    
18.         '取出每组最后一个数字存入结果数组
    
19.         arr(j, 1) = arr1(i, 1)
    
20.     Next
    
21.    
    
22.     '判断是否有提取到数据，避免出错
    
23.     If j > 0 Then
    
24.         Application.ScreenUpdating = False
    
25.         
    
26.         '先清除D列原有数据
    
27.         Columns("d").ClearContents
    
28.         
    
29.         '写回单元格
    
30.         Range("d1").Resize(j).Value = arr
    
31.         
    
32.         Application.ScreenUpdating = True
    
33.         MsgBox "提取完成"
    
34.     End If
    
35. End Sub

复制代码

hwc2ycy

分离数据附件.rar (16.13 KB, 下载次数: 4)

2013-5-15 19:42 上传

点击文件名下载附件