Do While Looping

Question

私はC：ドライブの200以上のファイルを見ているこのコードを持っています......そして、3行目から値を探しています。 .COL Pには値が入っていますか？ "はい"次に、行全体をコピー.....（任意のセルに値P colがある場合はそれに気づきます）.... .... col Pの行に移動します.....行全体をコピーしますcol P値に依存します....（値がCドライブファイルのCol Pに基づいて値を取得する場合）、その行を新しいファイルにのみコピーします。.....デスクトップ上で...そのデスクトップファイルを閉じて移動しますCol Pのデータを検索する次のファイル行へ行をデスクトップファイルにコピーする...何度も繰り返しています.............次のファイルに移動することができません。 CファイルのP colの次の再設定された値......... 1つのファイルのみ..... Cの200個のファイルのスタック内の次のファイルに移動する必要があります。 P ....全体の行をコピーし、最初のデータポイントがその最後のデータポイントの直下にあるデスクトップファイルに追加します（それが動作しています）。最後に、「xファイルの量検索した "ほとんどのものが動作する。私の "次の"が私のFor文に対応するべき場所を見つけ出すことはできません。私のループが "Do" statmentのために行くべき場所を見つけ出すことができますか？ ...ありがとうございました。

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