|
根据你的程序修改如下:- Sub Find的第几次查找()
- '目的用 Find 查找出每个工作表第五次车间出现的周边数据在哪里,并复制出来。
- '由于每个第五次车间出现的位置不一样,如新建文件夹工作表中黄色单元格就是要复制的数据。复制到本工作簿中。
-
- Dim MyPath$, MyFile$, arr, brr(1 To 100000, 1 To 10), i&, j&, m&, R&, Sh, C As Range, x%
- ' Rows("2:" & Rows.Count).Delete
- Application.ScreenUpdating = False
- MyPath = ThisWorkbook.Path & "\新建文件夹"
- MyFile = Dir(MyPath & "*.xls*")
- Do While MyFile <> ""
- Set wb = Workbooks.Open(MyPath & MyFile, UpdateLinks:=0)
- x = 0
- For Each Sh In wb.Worksheets
- x = 0
- R = Sh.Cells(Sh.Rows.Count, "A").End(xlUp).Row
- If Not IsEmpty(Sh.UsedRange) Then
- Set C = Sh.Columns("A:A").Find("车间", Range("A" & R), xlValues, xlWhole, xlByRows, xlNext, True, False, False) '如果表示第五次车间出现的周边数据??
- firstaddress = C.Address
- x = 1
- Do
- Set C = Sh.Columns("A:A").FindNext(C)
- If C.Address <> firstaddress Then
- x = x + 1
- End If
- Loop While Not C Is Nothing And C.Address <> firstaddress And x < 5
- If Not C Is Nothing Then
- arr = C.CurrentRegion '如果表示第五次车间出现的周边数据的数组??
- For i = 2 To UBound(arr)
- m = m + 1
- brr(m, 1) = arr(i, 1)
- brr(m, 2) = arr(i, 2)
- brr(m, 3) = arr(i, 3)
- Next i
- End If
- End If
- Next Sh
- wb.Close False
- MyFile = Dir
- Loop
- If m > 0 Then Cells(2, 1).Resize(m, 3) = brr
- Application.ScreenUpdating = True
- MsgBox "汇总完成,请查看!", 64, "提示"
- End Sub
复制代码 |
|