Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2005|回复: 2

[已解决]筛选与复制,要求在附件中

[复制链接]
发表于 2016-7-6 10:25 | 显示全部楼层 |阅读模式
筛选与复制.rar (6.12 KB, 下载次数: 9)
发表于 2016-7-6 11:29 | 显示全部楼层    本楼为最佳答案   
试一下:
  1. Sub test()
  2. Dim Dic, Wb As Workbook, Ws As Worksheet, Arr, Arrt(), n&, FN$, Str$, Rng As Range, R As Range, Str2$, x%
  3. Set Dic = CreateObject("scripting.dictionary")
  4. Application.ScreenUpdating = False
  5. FN = Dir(ThisWorkbook.Path & "\*.xls*")
  6. Do While FN <> ""
  7.     If FN <> ThisWorkbook.Name Then
  8.         Set Wb = GetObject(ThisWorkbook.Path & "" & FN)
  9.         With Wb
  10.             For Each Ws In .Worksheets
  11.                 With Ws
  12.                     n = .Cells(.Rows.Count, 1).End(xlUp).Row
  13.                     Arr = .Range("A1:C" & n)
  14.                     For i = 3 To n
  15.                         If Arr(i, 2) >= 80 And Arr(i, 3) >= 80 Then
  16.                             x = x + 1
  17.                             ReDim Preserve Arrt(1 To 6, 1 To x)
  18.                             Arrt(1, x) = Replace(FN, ".xls", "")
  19.                             Arrt(2, x) = Ws.Name
  20.                             Arrt(3, x) = i
  21.                             Arrt(4, x) = Arr(i, 1)
  22.                             Arrt(5, x) = Arr(i, 2)
  23.                             Arrt(6, x) = Arr(i, 3)
  24.                         End If
  25.                     Next
  26.                 End With
  27.             Next Ws
  28.         End With
  29.         Wb.Close False
  30.     End If
  31.     FN = Dir
  32. Loop
  33. Sheet1.Range("A2").Resize(x, 6) = Application.WorksheetFunction.Transpose(Arrt)
  34. Set Wb = Nothing
  35. Application.ScreenUpdating = True
  36. Set Dic = Nothing
  37. End Sub
复制代码

评分

参与人数 1 +2 收起 理由
ww0000 + 2 赞一个

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2016-7-6 11:36 | 显示全部楼层
老司机带带我 发表于 2016-7-6 11:29
试一下:

试了一下,很好,谢谢
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 19:29 , Processed in 0.290947 second(s), 13 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表