[已解决]（求助）如何批量抽取列数据到指定地方

晓敏

如附件 批量抽取C列数据.rar (236.69 KB, 下载次数: 23)

2012-3-13 09:44 上传

点击文件名下载附件

谢谢老师们！

最佳答案

月排行榜 / 总排行榜

liuguansky

2012-3-13 10:01

1. Sub T()
   
2.     Dim Arr, i&, j As Byte, s$, sP$, Wb
   
3.     Application.ScreenUpdating = False
   
4.     Cells.Clear
   
5.     s = ThisWorkbook.Path & "\数据文件"
   
6.     sP = Dir(s & "*.xlsx")
   
7.     Do While sP <> ""
   
8.         Set Wb = GetObject(s & sP)
   
9.         With Wb.Worksheets(1)
   
10.             Arr = .Range(.Cells(1, 3), .Cells(.Rows.Count, 3).End(3)).Value
    
11.         End With
    
12.         Wb.Close False
    
13.         If IsArray(Arr) Then
    
14.             j = j + 1
    
15.             Cells(1, j).Resize(UBound(Arr)) = Arr
    
16.         Else
    
17.             Cells(1, j) = Arr
    
18.         End If
    
19.         sP = Dir
    
20.     Loop
    
21.     Application.ScreenUpdating = True
    
22.     MsgBox "处理完毕"
    
23. End Sub
    

复制代码

批量抽取C列数据.rar (254.8 KB, 下载次数: 30)

2012-3-13 10:00 上传

点击文件名下载附件

跳转到最佳答案楼层

liuguansky

1. Sub T()
   
2.     Dim Arr, i&, j As Byte, s$, sP$, Wb
   
3.     Application.ScreenUpdating = False
   
4.     Cells.Clear
   
5.     s = ThisWorkbook.Path & "\数据文件"
   
6.     sP = Dir(s & "*.xlsx")
   
7.     Do While sP <> ""
   
8.         Set Wb = GetObject(s & sP)
   
9.         With Wb.Worksheets(1)
   
10.             Arr = .Range(.Cells(1, 3), .Cells(.Rows.Count, 3).End(3)).Value
    
11.         End With
    
12.         Wb.Close False
    
13.         If IsArray(Arr) Then
    
14.             j = j + 1
    
15.             Cells(1, j).Resize(UBound(Arr)) = Arr
    
16.         Else
    
17.             Cells(1, j) = Arr
    
18.         End If
    
19.         sP = Dir
    
20.     Loop
    
21.     Application.ScreenUpdating = True
    
22.     MsgBox "处理完毕"
    
23. End Sub
    

复制代码

批量抽取C列数据.rar (254.8 KB, 下载次数: 30)

2012-3-13 10:00 上传

点击文件名下载附件

晓敏

liuguansky 发表于 2012-3-13 10:01

又快又准，谢谢。

liziyuliziyu7

dddddddddddddddddddddddddd