[已解决]麻烦各位老师指导看如何实现附件所述功能，谢谢！~

fywb2000

麻烦各位老师指导看如何实现附件所述功能，谢谢！~ 工作簿1.rar (10.22 KB, 下载次数: 19)

2013-4-4 23:06 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-4-5 00:09

1. Sub 提取数据()
   
2.     Dim lrow&, arr
   
3.     lrow = Cells(Rows.Count, "i").End(xlUp).Row
   
4.     arr = Range("i5:bv" & lrow)
   
5.     Dim str$
   
6.     Dim k&, i&
   
7.     k = UBound(arr)
   
8.     For i = LBound(arr, 2) To UBound(arr, 2)
   
9.         If VBA.IsNumeric(arr(k, i)) Then
   
10.             str = str & i & ","
    
11.         End If
    
12.     Next
    
13. 
    
14.     If Len(str) > 0 Then
    
15.         str = Left(str, Len(str) - 1)
    
16. 
    
17.         Dim arrPos
    
18.         arrPos = Split(str, ",")
    
19.         Dim result()
    
20.         ReDim result(1 To k, 1 To UBound(arrPos) + 1)
    
21.         For i = LBound(arr) To UBound(arr)
    
22.             For k = LBound(result, 2) To UBound(result, 2)
    
23.                 result(i, k) = arr(i, arrPos(k - 1))
    
24.             Next
    
25.         Next
    
26.         Sheet2.Range("a1").Resize(i - 1, k - 1) = result
    
27.         MsgBox "OK!"
    
28.     End If
    
29. End Sub

复制代码

跳转到最佳答案楼层

tinata

也想学习~~~~~~~~~~

hwc2ycy

1. Sub 提取数据()
   
2.     Dim lrow&, arr
   
3.     lrow = Cells(Rows.Count, "i").End(xlUp).Row
   
4.     arr = Range("i5:bv" & lrow)
   
5.     Dim str$
   
6.     Dim k&, i&
   
7.     k = UBound(arr)
   
8.     For i = LBound(arr, 2) To UBound(arr, 2)
   
9.         If VBA.IsNumeric(arr(k, i)) Then
   
10.             str = str & i & ","
    
11.         End If
    
12.     Next
    
13. 
    
14.     If Len(str) > 0 Then
    
15.         str = Left(str, Len(str) - 1)
    
16. 
    
17.         Dim arrPos
    
18.         arrPos = Split(str, ",")
    
19.         Dim result()
    
20.         ReDim result(1 To k, 1 To UBound(arrPos) + 1)
    
21.         For i = LBound(arr) To UBound(arr)
    
22.             For k = LBound(result, 2) To UBound(result, 2)
    
23.                 result(i, k) = arr(i, arrPos(k - 1))
    
24.             Next
    
25.         Next
    
26.         Sheet2.Range("a1").Resize(i - 1, k - 1) = result
    
27.         MsgBox "OK!"
    
28.     End If
    
29. End Sub

复制代码

fywb2000

hwc2ycy 发表于 2013-4-5 00:09

谢谢老师指导~非常感谢~