我在下面的代码中查看C：驱动器上的200多个文件......然后我正在寻找从第3行开始的值....看看col P ..... COL P包含值？ “是”然后复制整行.....（如果在任何单元格中有一个值P col ...然后它会注意到它）....转到col P的那一行.....复制整行取决于col P值....（如果值存在基于C驱动器文件中的Col P的抓取行）并将该行仅复制到新文件.....在桌面上...关闭该桌面文件并移动下一个文件行搜索Col P ....中的数据将行复制到桌面文件...一遍又一遍.............我无法让它移动到下一个文件或C文件的P col中的下一个重新调整的值.......只有一个文件.....需要它转到C盘中200个文件堆栈中的下一个文件，在Col中搜索每一行的值P ....复制整行并将其添加到第一个数据点所在的桌面文件中......在最后一个数据点之下（有效）最后它给了我一个msg框，上面写着“x个文件”搜索“其中大部分都有效。可以弄清楚我的“下一个”应该与我的For语句相对应的地方..我可以找出我的Loop应该去哪里“Do”的声明（做的同时做，直到）我想我有太多的事情.. ...请帮忙纠正谢谢。
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"
答案 0 :(得分：0)
未经测试但应该或多或少地存在：
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