[已解决]【求助】请问如何将列名相同的一列数据抽取出来

reisword

就是在一组无规律的表中，将列名相同的一列数据复制出来

再在空白地方粘贴

附件为实验数据，不知如何将列名为“累计沉降值㎜”的所有列复制出来

谢谢各位大师的帮助，感激不尽

最佳答案

月排行榜 / 总排行榜

sunjing-zxl

2011-6-12 13:08

回复 reisword 的帖子

上面用技巧给你做的，
下面用VBA给你做

1. 
   
2. Sub 数据生成()
   
3.     Dim Ro As Long, Co As Long, i As Long
   
4.     With Sheet1
   
5.         Ro = .[A65536].End(xlUp).Row
   
6.         For Co = 1 To .[A1].End(xlToRight).Column
   
7.             If .Cells(1, Co) = "累计沉降值㎜" Then
   
8.                 i = i + 1
   
9.                 .Range(.Cells(1, Co), .Cells(Ro, Co)).Copy Sheet3.Cells(1, i)
   
10.             End If
    
11.         Next Co
    
12.     End With
    
13. End Sub
    
14. 
    
15. Sub 清楚数据()
    
16.     Dim Ro As Long
    
17.     Dim Co As Long
    
18.     With Sheet3
    
19.         Co = .[A1].End(xlToRight).Column
    
20.         Ro = .[A1].End(xlDown).Row
    
21.         .Range(.Cells(1, 1), .Cells(Ro, Co)).ClearContents
    
22.     End With
    
23. End Sub

复制代码

附件： 实验数据.rar (16.62 KB, 下载次数: 43)

2011-6-12 13:09 上传

点击文件名下载附件

跳转到最佳答案楼层

reisword

PS:如果要将这段代码复制到其他表中需要注意什么问题呢?

sunjing-zxl

回复 reisword 的帖子

sunjing-zxl

回复 reisword 的帖子

上面用技巧给你做的，
下面用VBA给你做

1. 
   
2. Sub 数据生成()
   
3.     Dim Ro As Long, Co As Long, i As Long
   
4.     With Sheet1
   
5.         Ro = .[A65536].End(xlUp).Row
   
6.         For Co = 1 To .[A1].End(xlToRight).Column
   
7.             If .Cells(1, Co) = "累计沉降值㎜" Then
   
8.                 i = i + 1
   
9.                 .Range(.Cells(1, Co), .Cells(Ro, Co)).Copy Sheet3.Cells(1, i)
   
10.             End If
    
11.         Next Co
    
12.     End With
    
13. End Sub
    
14. 
    
15. Sub 清楚数据()
    
16.     Dim Ro As Long
    
17.     Dim Co As Long
    
18.     With Sheet3
    
19.         Co = .[A1].End(xlToRight).Column
    
20.         Ro = .[A1].End(xlDown).Row
    
21.         .Range(.Cells(1, 1), .Cells(Ro, Co)).ClearContents
    
22.     End With
    
23. End Sub

复制代码

附件： 实验数据.rar (16.62 KB, 下载次数: 43)

2011-6-12 13:09 上传

点击文件名下载附件

reisword

回复 sunjing-zxl 的帖子

膜拜，太感谢大师了，态度好，又仔细，非常的感谢

嗯，您的VBA的代码就非常明朗，看起来没多大问题。

再次非常感谢

sctcp

不错，学习一下

岁寒三友

学习一下！

1. 
   
2. Sub 复制指定列()
   
3. Dim iCol As Integer
   
4. Dim i As Integer
   
5. Dim iCount As Integer
   
6. Application.ScreenUpdating = False
   
7. Sheet1.Range("A1").CurrentRegion.Copy Sheet3.Range("A1")
   
8. With Sheet3
   
9.      iCol = .[iv1].End(xlToLeft).Column
   
10.      For i = iCol To 1 Step -1
    
11.         If .Cells(1, i) <> "累计沉降值㎜" Then
    
12.            .Columns(i).Delete xlToLeft
    
13.         End If
    
14.      Next
    
15. End With
    
16. Application.ScreenUpdating = True
    
17. End Sub
    

复制代码