[已解决]请教数据的提取

海水鱼

请看附件谢谢！

最佳答案

月排行榜 / 总排行榜

雪舞子

2015-6-22 22:30

楼主测试：

1. Sub 提取数据()
   
2.     Dim arr, ar, i%, j%, brr(0, 2 To 11)
   
3.     arr = [a8].CurrentRegion
   
4.     For i = 2 To UBound(arr)
   
5.         For j = 2 To UBound(arr, 2)
   
6.             If arr(i, j) Then brr(0, j) = brr(0, j) & " " & arr(i, 1)
   
7.         Next
   
8.     Next
   
9.     [x8:ag200] = ""
   
10.     [x8:ag200].NumberFormatLocal = "@"
    
11.     For i = 2 To 11
    
12.         If brr(0, i) <> "" Then
    
13.             ar = Split(Mid(brr(0, i), 2))
    
14.             Cells(8, 22 + i).Resize(UBound(ar) + 1) = Application.Transpose(ar)
    
15.         End If
    
16.     Next
    
17. End Sub
    

复制代码

请教数据的提取.rar (21.71 KB, 下载次数: 24)

2015-6-22 22:30 上传

点击文件名下载附件

跳转到最佳答案楼层

雪舞子

楼主测试：

1. Sub 提取数据()
   
2.     Dim arr, ar, i%, j%, brr(0, 2 To 11)
   
3.     arr = [a8].CurrentRegion
   
4.     For i = 2 To UBound(arr)
   
5.         For j = 2 To UBound(arr, 2)
   
6.             If arr(i, j) Then brr(0, j) = brr(0, j) & " " & arr(i, 1)
   
7.         Next
   
8.     Next
   
9.     [x8:ag200] = ""
   
10.     [x8:ag200].NumberFormatLocal = "@"
    
11.     For i = 2 To 11
    
12.         If brr(0, i) <> "" Then
    
13.             ar = Split(Mid(brr(0, i), 2))
    
14.             Cells(8, 22 + i).Resize(UBound(ar) + 1) = Application.Transpose(ar)
    
15.         End If
    
16.     Next
    
17. End Sub
    

复制代码

请教数据的提取.rar (21.71 KB, 下载次数: 24)

2015-6-22 22:30 上传

点击文件名下载附件