|
本帖最后由 huangwei0king 于 2011-11-1 13:56 编辑
- Sub 记录查询()
- Dim cent, s, i, j, p, n, m, pp
- Dim pt As String
- Dim t, fnanme
- Dim arr
- Dim brr() As String
- Application.ScreenUpdating = False
- On Error Resume Next
- pt = ThisWorkbook.Path
- Set cent = CreateObject("Scripting.FileSystemObject")
- Set s = cent.GetFolder(pt)
- t = ThisWorkbook.Sheets(1).Range("c2")
- For Each i In s.Files
- If i <> ThisWorkbook.FullName Then
- Workbooks.Open Filename:=i
- fname = Left(Workbooks(2).Name, 6)
- For j = 1 To 3
- p = Workbooks(2).Sheets(j).Range("a65536").End(xlUp).Row
- arr = Workbooks(2).Sheets(j).Range("a4:f" & p)
- For n = 1 To UBound(arr)
- If arr(n, 2) = t Then
- m = m + 1
- ReDim Preserve brr(1 To 8, 1 To m)
- brr(1, m) = arr(n, 1)
- brr(2, m) = arr(n, 2)
- brr(3, m) = arr(n, 3)
- brr(4, m) = arr(n, 4)
- brr(5, m) = arr(n, 5)
- brr(6, m) = arr(n, 6)
- brr(7, m) = fname
- brr(8, m) = Workbooks(2).Sheets(j).Name
- End If
- Next
- Erase arr
- Next
- Workbooks(2).Close SaveChanges:=False
- End If
- Next
- pp = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row
- If pp > 3 Then
- ThisWorkbook.Sheets(1).Range("a4:h" & pp).ClearContents
- End If
- ThisWorkbook.Sheets(1).Range("a4").Resize(UBound(brr, 2), 8) = Application.Transpose(brr)
- Erase brr
- Application.ScreenUpdating = True
- End Sub
- 附件传不上来,太大了,400多K!
复制代码 |
评分
-
1
查看全部评分
-
|