Do While Looping

Question

У меня есть этот код ниже, который смотрит на 200+ файлов на C: drive ...... тогда я ищу значения, начиная со строки 3 .... посмотрим на col P .... .COL P содержит значения? «да», то скопируйте целую строку ..... (если в любой ячейке есть значение P col ... тогда она замечает это) .... идет в эту строку col P ..... копирует целую строку зависит от значений col P .... (если существует значение grab row на основе Col P в файлах дисков C) и копирует эту строку только в новый файл ..... на рабочем столе ... закрывает этот файл рабочего стола и перемещается к следующей строке файла, ищущей данные в Col P .... для копирования строки в файл рабочего стола ... снова и снова ............. Я не могу заставить его перейти к следующему файлу или следующее реконструированное значение в P col файла C ....... только ОДИН файл ..... нужно, чтобы он перешел к следующему в стеке из 200 файлов на диске C, который ищет каждую строку для значения в Col P .... скопируйте целую строку и добавьте ее в этот файл рабочего стола, где первая точка данных ... под этой последней точкой данных (есть эта работа). В конце она дает мне поле msg, в котором говорится «x количество файлов «Большинство из них работает. Можете выяснить, куда мой «следующий» должен идти в соответствии с моим заявлением «For» .. или я могу выяснить, где мой цикл должен идти или для «Делать» (делать пока и делать до) Я думаю, что я слишком много продолжаю ... ... пожалуйста, помогите исправить Спасибо.

Sub copy_to_new_sheet_clump() 
Dim wbk As Workbook 
Dim filename As String 
Dim path As String 
Dim count As Integer 
path = "C:\Ben_Excel4\" 
filename = Dir(path & "*.xls*") 
'-------------------------------------------- 
'OPEN EXCEL FILES 
Do Until Len(filename) > 0 'IF NEXT FILE EXISTS THEN 
count = count + 1 ' this is to count all files for msg box at end 
Set wbk = Workbooks.Open(path & filename) ' looking in 200+ files in C: 

'assuming the data being searched for is in Equipment Sheet 
Sheets("Equipment").Select ' this is correct sheet for 200+ files in C: 
' get end of rows/number of rows to look at by looking down COL P to end 
rowCount = Cells(Cells.Rows.count, 1).End(xlUp).row 

For i = 3 To rowCount ' starting at row three search P column for data 
         'assuming the number is contained in a cell on COL P 
Range("P" & i).Select 
ActiveCell.Select 
'have data and find bottom of active sheet and paste one row below last data pasted 
Application.ScreenUpdating = False 

Do While ActiveCell.Value <> Empty 

Selection.EntireRow.Select 
' there are hyperlinks have to get rid of on the sheet...ha...dont ask. 
Selection.Hyperlinks.Delete 

Selection.EntireRow.Copy 'copy whats found in Col P 

Application.ScreenUpdating = False 
'saves to desk top file where all the rows for files searched that have data 
' in col P and stacks it nicely in this Book1.xls on desktop sheet 1   

Workbooks.Open ("C:\Users\patrickf\Desktop\Book1.xlsx") 
Sheets("Sheet1").Activate 
Range("A4").Select 'starts at row 4 for pasting 
rowCount = Cells(Cells.Rows.count, "A").End(xlUp).row 
Sheets("Sheet1").Range("a" & rowCount + 1).Select 
ActiveSheet.PastE 
Application.ScreenUpdating = False 
ActiveWorkbook.SaveAs filename:="C:\Users\patrickf\Desktop\Book1.xlsx", _ 
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 
ActiveWindow.Close 'saves desktop file and closes it.... 
Application.ScreenUpdating = False 
Exit Do 

Application.ScreenUpdating = False 


Application.ScreenUpdating = False 
Loop 

MY ISSUE = 'somehow need it to go to NEXT file in C drive out of the 200 
      ' sitting there and search by Col P for "not empty" ....grab 
      ' row...paste to desktop file....then next file. 

MsgBox count & " : files found in folder" 

Answer 1

непроверенная, но должна быть более или менее есть:

Sub copy_to_new_sheet_clump() 

    'use a constant for fixed values 
    Const FOLDER As String = "C:\Ben_Excel4\" 
    Const SHT_SOURCE As String = "Equipment" 
    Const WB_DEST As String = "C:\Users\patrickf\Desktop\Book1.xlsx" 
    Const SHT_DEST As String = "Sheet1" 

    Dim wbk As Workbook, f As String, shtSrc As Worksheet 
    Dim count As Integer, wbDest As Workbook, rngDest As Range 
    Dim i As Long 

    Set wbDest = Workbooks.Open(WB_DEST) 

    'set the first destination row 
    Set rngDest = wbDest.Sheets(SHT_DEST).Cells(Rows.count, 1).End(xlUp).Offset(1, 0) 
    count = 0 

    f = Dir(FOLDER & "*.xls*") 
    Do While Len(f) > 0 

     Set wbk = Workbooks.Open(FOLDER & f, ReadOnly:=True) 
     Set shtSrc = wbk.Sheets(SHT_SOURCE) 

     For i = 3 To shtSrc.Cells(shtSrc.Rows.count, 1).End(xlUp).Row 
      With shtSrc.Rows(i) 
       'any value in Col P ? 
       If .Cells(1, "P").Value <> "" Then 
        .Hyperlinks.Delete 
        .Copy rngDest      'copy the row 
        Set rngDest = rngDest.Offset(1, 0) 'next paste row in destination sheet 
       End If 
      End With 
     Next i 

     wbk.Close False 'no save 

     count = count + 1 
     f = Dir() 'next file (if any) 
    Loop 

    wbDest.Close True 'save changes 

    MsgBox count & " : files found in folder '" & FOLDER & "'" 

End Sub