[已解决]如何用代码批量提取数据

李全有

附件 批量提取数据附件.zip (317.18 KB, 下载次数: 12)

2015-2-7 11:19 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

芐雨

2015-2-7 12:15

1. Sub tt()
   
2.     Dim arr, brr, i&, j&, x&, myPath$, myFile$
   
3.     Dim sht As Worksheet, wb As Workbook, sh As Worksheet
   
4. 
   
5.     Application.ScreenUpdating = False    '禁刷新
   
6.     Application.Calculation = xlManual    '禁计算
   
7.     fs = Sheets("sheet1").Range("B1")     '查找的字符
   
8.     Set sht = Sheets("sheet2")             '工作表
   
9.     sht.Cells.Clear                    '清除单元格
   
10.     myPath = ThisWorkbook.Path & ""   '当前路径
    
11.     myFile = Dir(myPath & "*.xls")     'excel文件名
    
12. 
    
13.     ReDim brr(1 To 1000, 1 To 60)    '创建数组brr
    
14. 
    
15.     Do While myFile <> ""    '文件名不为空时执行
    
16.         If myFile <> sht.Parent.Name Then    '文件名不等于当前文件名时执行
    
17.             Set wb = Workbooks.Open(myPath & myFile)   '打开文件，记为wb
    
18.             Set sh = wb.Sheets("sheet1")
    
19.             arr = sh.Range("A1").CurrentRegion
    
20.             For i = 1 To UBound(arr)
    
21.                 If InStr(arr(i, 1), fs) = 1 Then   '开头为fs
    
22.                     x = x + 1
    
23.                     For j = 1 To UBound(arr, 2)
    
24.                         brr(x, j) = arr(i, j)      '赋值
    
25.                     Next
    
26.                      brr(x, j) = myFile           '最后一列为文件名
    
27.                 End If
    
28.             Next
    
29.             wb.Close   '关闭文件
    
30.         End If
    
31.         myFile = Dir  '下一个文件名
    
32.     Loop
    
33.     sht.Range("A1").Resize(x, 60) = brr          '赋值
    
34.     Application.Calculation = xlAutomatic        '自动计算
    
35.     Application.ScreenUpdating = True            '刷新
    
36. End Sub

复制代码

跳转到最佳答案楼层

芐雨

1. Sub tt()
   
2.     Dim arr, brr, i&, j&, x&, myPath$, myFile$
   
3.     Dim sht As Worksheet, wb As Workbook, sh As Worksheet
   
4. 
   
5.     Application.ScreenUpdating = False    '禁刷新
   
6.     Application.Calculation = xlManual    '禁计算
   
7.     fs = Sheets("sheet1").Range("B1")     '查找的字符
   
8.     Set sht = Sheets("sheet2")             '工作表
   
9.     sht.Cells.Clear                    '清除单元格
   
10.     myPath = ThisWorkbook.Path & ""   '当前路径
    
11.     myFile = Dir(myPath & "*.xls")     'excel文件名
    
12. 
    
13.     ReDim brr(1 To 1000, 1 To 60)    '创建数组brr
    
14. 
    
15.     Do While myFile <> ""    '文件名不为空时执行
    
16.         If myFile <> sht.Parent.Name Then    '文件名不等于当前文件名时执行
    
17.             Set wb = Workbooks.Open(myPath & myFile)   '打开文件，记为wb
    
18.             Set sh = wb.Sheets("sheet1")
    
19.             arr = sh.Range("A1").CurrentRegion
    
20.             For i = 1 To UBound(arr)
    
21.                 If InStr(arr(i, 1), fs) = 1 Then   '开头为fs
    
22.                     x = x + 1
    
23.                     For j = 1 To UBound(arr, 2)
    
24.                         brr(x, j) = arr(i, j)      '赋值
    
25.                     Next
    
26.                      brr(x, j) = myFile           '最后一列为文件名
    
27.                 End If
    
28.             Next
    
29.             wb.Close   '关闭文件
    
30.         End If
    
31.         myFile = Dir  '下一个文件名
    
32.     Loop
    
33.     sht.Range("A1").Resize(x, 60) = brr          '赋值
    
34.     Application.Calculation = xlAutomatic        '自动计算
    
35.     Application.ScreenUpdating = True            '刷新
    
36. End Sub

复制代码

芐雨

附件：

批量提取数据附件.zip (327.81 KB, 下载次数: 9)

2015-2-7 12:16 上传

点击文件名下载附件

dsmch

1. Sub Macro1()
   
2. Dim mypath$, wj$, arr, brr, i&, j%, s&
   
3. ReDim brr(1 To 20000, 1 To 200)
   
4. mypath = ThisWorkbook.Path & ""
   
5. wj = Dir(mypath & "*.xls*")
   
6. Sheet1.Activate
   
7. zf = [b1]
   
8. Application.ScreenUpdating = False
   
9. Do While wj <> ""
   
10.     If wj <> ThisWorkbook.Name Then
    
11.         With GetObject(mypath & wj)
    
12.             arr = .Sheets(1).Range("a1").CurrentRegion
    
13.             wb = .Name
    
14.             .Close 0
    
15.         End With
    
16.         For i = 1 To UBound(arr)
    
17.             If arr(i, 1) Like "*" & zf & "*" Then
    
18.                 s = s + 1
    
19.                 For j = 1 To UBound(arr, 2)
    
20.                     brr(s, j) = arr(i, j)
    
21.                 Next
    
22.                 brr(s, UBound(arr, 2)) = wb
    
23.             End If
    
24.         Next
    
25.     End If
    
26.     wj = Dir
    
27. Loop
    
28. Sheet2.Activate
    
29. Range("a1").Resize(s, UBound(arr, 2) + 1) = brr
    
30. Application.ScreenUpdating = True
    
31. End Sub

复制代码