[已解决]批量查询合格数据的问题

李全有

附件 提取数据附件.zip (335.35 KB, 下载次数: 18)

2015-4-3 22:01 上传

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

最佳答案

月排行榜 / 总排行榜

dsmch

2015-4-4 10:52

1. Sub Macro1()
   
2. Dim mypath$, wj$, sht As Worksheet, arr
   
3. mypath = ThisWorkbook.Path & ""
   
4. Set sht = ThisWorkbook.Sheets(2)
   
5. sht.UsedRange.ClearContents
   
6. wj = Dir(mypath & "*.xls*")
   
7. Application.ScreenUpdating = False
   
8. Do While wj <> ""
   
9.     If wj <> ThisWorkbook.Name Then
   
10.        With Workbooks.Open(Filename:=mypath & wj)
    
11.             gzb = .Name
    
12.             arr = Sheets(1).Range("a1").CurrentRegion
    
13.             n = UBound(arr, 2)
    
14.             For i = 1 To UBound(arr)
    
15.                 If arr(i, n) = arr(i, n - 2) And arr(i, n) = arr(i, n - 4) Then
    
16.                     s2 = s2 + 1
    
17.                     s = IIf(s2 = 1, 1, sht.Cells(Rows.Count, 1).End(xlUp).Row + 1)
    
18.                     Cells(i, 1).Resize(1, n).Copy sht.Cells(s, 1)
    
19.                     sht.Cells(s, n + 2) = gzb
    
20.                 End If
    
21.             Next
    
22.             .Close 0
    
23.        End With
    
24.     End If
    
25. wj = Dir
    
26. Loop
    
27. Application.ScreenUpdating = True
    
28. End Sub

复制代码

跳转到最佳答案楼层

李全有

真诚求助。

dsmch

1. Sub Macro1()
   
2. Dim mypath$, wj$, sht As Worksheet, arr
   
3. mypath = ThisWorkbook.Path & ""
   
4. Set sht = ThisWorkbook.Sheets(2)
   
5. sht.UsedRange.ClearContents
   
6. wj = Dir(mypath & "*.xls*")
   
7. Application.ScreenUpdating = False
   
8. Do While wj <> ""
   
9.     If wj <> ThisWorkbook.Name Then
   
10.        With Workbooks.Open(Filename:=mypath & wj)
    
11.             gzb = .Name
    
12.             arr = Sheets(1).Range("a1").CurrentRegion
    
13.             n = UBound(arr, 2)
    
14.             For i = 1 To UBound(arr)
    
15.                 If arr(i, n) = arr(i, n - 2) And arr(i, n) = arr(i, n - 4) Then
    
16.                     s2 = s2 + 1
    
17.                     s = IIf(s2 = 1, 1, sht.Cells(Rows.Count, 1).End(xlUp).Row + 1)
    
18.                     Cells(i, 1).Resize(1, n).Copy sht.Cells(s, 1)
    
19.                     sht.Cells(s, n + 2) = gzb
    
20.                 End If
    
21.             Next
    
22.             .Close 0
    
23.        End With
    
24.     End If
    
25. wj = Dir
    
26. Loop
    
27. Application.ScreenUpdating = True
    
28. End Sub

复制代码

lmze2000

李全有 发表于 2015-4-4 07:02
真诚求助。

1. Sub 合格数据()
   
2.     Dim FileName$, Fn$, Mypath$, Wb As Workbook, Sht As Worksheet, Zsht As Worksheet
   
3.     Dim Arr, i%
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         If .Show Then Mypath = .SelectedItems(1) Else Exit Sub
   
6.     End With
   
7.     If Right(Mypath, 1) <> "" Then Mypath = Mypath & ""
   
8.     FileName = Dir(Mypath & "*.xlsx")
   
9.     Set Zsht = ThisWorkbook.Sheets("sheet2")
   
10.     Zsht.Cells.ClearContents
    
11.     Application.ScreenUpdating = False
    
12.     t = Timer
    
13.     Do While FileName <> ""
    
14.         If FileName <> ThisWorkbook.Name Then
    
15.             Fn = Mypath & FileName
    
16.             Set Wb = Workbooks.Open(Fn)
    
17.             Set Sht = Wb.Sheets(1)
    
18.             Arr = Sht.UsedRange
    
19.             n = UBound(Arr, 2)
    
20.             For i = 1 To UBound(Arr)
    
21.                 If Cells(i, n - 2) = Cells(i, n - 4) And Cells(i, n - 2) = Cells(i, n) Then
    
22.                 Sht.Range(Cells(i, 1), Cells(i, n)).Copy Zsht.[a1].Offset(Zsht.Cells(Rows.Count, 1).End(3).Row)
    
23.                 Zsht.Cells(Zsht.Cells(Rows.Count, 1).End(3).Row, n + 2) = Wb.Name
    
24.                 End If
    
25.             Next
    
26.             Wb.Close False
    
27.         End If
    
28.     FileName = Dir
    
29.     Loop
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "提取完成，用时" & Format(Timer - t, "0.00") & "秒"
    
32. End Sub

复制代码