While While Looping

Question

我有下面這段代碼，看起來在C：驅動器上有200多個文件......然後我正在尋找從第3行開始的值......看看col P .... .COL P包含值？ 「是」然後複製整行.....（如果在任何單元格中有一個值P col ...那麼它會注意到它）....進入col P的那一行.....複製整行依賴col P值....（如果存在的值基於C驅動器文件中的Col P抓取行），並將該行僅複製到新文件.....在桌面上...關閉該桌面文件並移動到下一個文件行搜索Col P ....中的數據以將行復制到桌面文件...一遍又一遍.............我無法讓它移動到下一個文件或在C文件的P列中的下一個重新調整的值.......只有一個文件.....需要它進入C文件中的200個文件的堆棧中的下一個文件，在Col中搜索每行以獲取值P ....複製整行，並將其添加到該桌面文件的第一個數據點是..恰好在最後一個數據點（有工作）在最後，它給了我一個msg框，說「x的文件數量搜索「大部分工作。可以找出我的「下一個」應該去哪裏對應於我的For語句..也可以找出我的循環應該去哪裏做「Do」表達（do while and do until）我認爲我有太多的事情要去.. ...請幫助正確謝謝。

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