[已解决]（求助）如何批量提取表格数据？

Hotmailzwj

如附件 批量提取数据附件.rar (46.99 KB, 下载次数: 38)

2012-6-10 15:10 上传

点击文件名下载附件
谢谢各位老师！

最佳答案

月排行榜 / 总排行榜

hrpotter

2012-6-10 16:14

1. Sub test()
   
2.     Dim ar, br(1 To 1000000, 1 To 1)
   
3.     Dim i As Long, j As Long, k As Long
   
4.     Dim f As String
   
5.     Dim num As Integer
   
6.     Dim wb As Workbook
   
7.     Application.ScreenUpdating = False
   
8.     num = Application.InputBox("请输入任意一个数(1-49):", , , , , , , 1)
   
9.     If num >= 1 And num <= 49 Then
   
10.         f = Dir(ThisWorkbook.Path & "\数据文件\*.xlsx")
    
11.         Sheets(1).Cells.Clear
    
12.         Do
    
13.             Set wb = Workbooks.Open(ThisWorkbook.Path & "\数据文件" & f)
    
14.             With wb.Sheets(1)
    
15.                 ar = .Range("a1:a" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    
16.             End With
    
17.             wb.Close
    
18.             k = 0
    
19.             Erase br
    
20.             For i = 5 To UBound(ar) - 1
    
21.                 If ar(i, 1) = num Then
    
22.                     For j = 1 To 6
    
23.                         br(k * 7 + j, 1) = ar(i + j - 5, 1)
    
24.                     Next
    
25.                     k = k + 1
    
26.                 End If
    
27.             Next
    
28.             ThisWorkbook.Sheets(1).Cells(1, Replace(f, ".xlsx", "")).Resize(7 * k, 1) = br
    
29.             f = Dir
    
30.         Loop Until Len(f) = 0
    
31.     End If
    
32.     Application.ScreenUpdating = True
    
33. End Sub

复制代码

跳转到最佳答案楼层

hrpotter

1. Sub test()
   
2.     Dim ar, br(1 To 1000000, 1 To 1)
   
3.     Dim i As Long, j As Long, k As Long
   
4.     Dim f As String
   
5.     Dim num As Integer
   
6.     Dim wb As Workbook
   
7.     Application.ScreenUpdating = False
   
8.     num = Application.InputBox("请输入任意一个数(1-49):", , , , , , , 1)
   
9.     If num >= 1 And num <= 49 Then
   
10.         f = Dir(ThisWorkbook.Path & "\数据文件\*.xlsx")
    
11.         Sheets(1).Cells.Clear
    
12.         Do
    
13.             Set wb = Workbooks.Open(ThisWorkbook.Path & "\数据文件" & f)
    
14.             With wb.Sheets(1)
    
15.                 ar = .Range("a1:a" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    
16.             End With
    
17.             wb.Close
    
18.             k = 0
    
19.             Erase br
    
20.             For i = 5 To UBound(ar) - 1
    
21.                 If ar(i, 1) = num Then
    
22.                     For j = 1 To 6
    
23.                         br(k * 7 + j, 1) = ar(i + j - 5, 1)
    
24.                     Next
    
25.                     k = k + 1
    
26.                 End If
    
27.             Next
    
28.             ThisWorkbook.Sheets(1).Cells(1, Replace(f, ".xlsx", "")).Resize(7 * k, 1) = br
    
29.             f = Dir
    
30.         Loop Until Len(f) = 0
    
31.     End If
    
32.     Application.ScreenUpdating = True
    
33. End Sub

复制代码

zsd5237

这个不知用于那里？