Excel高手，如何使用VBA来合并一个工作表里面的所有工作簿的指定行？

分太少了，发一个之前写过的合并多张Excel到单张Sheet的代码，供参考：

运行主函数 Excels_2_Sheet

Sub deleteCells() 

Dim s 
Set s = ThisWorkbook.Sheets("Sheet1") 
s.Cells.Delete 

For Each shp In s.Shapes 
shp.Delete 
Next shp 

Set s = Nothing 

End Sub 

Sub Excels_2_Sheet() 
Dim FilesToOpen 
Dim x As Integer, b, ws, ar 

'On Error GoTo ErrHandler 
Application.ScreenUpdating = False 


Call deleteCells 


Set b = Worksheets(1) 


FilesToOpen = Application.GetOpenFilename(FileFilter:="MicroSoft Excel文件, *.xlsx; *.xls", MultiSelect:=True, Title:="要合并的文件") 

If TypeName(FilesToOpen) = "Boolean" Then 
MsgBox "没有选中的文件" 
GoTo ExitHandler 
End If 

x = 1 
While x <= UBound(FilesToOpen) 

'Workbooks.Open Filename:=FilesToOpen(x) 

Call pub_wbOpenOrActive2(FilesToOpen(x)) 


Set ws = Sheets(1) 
ws.Activate 

With ws 
If .UsedRange.Address <> "$A$1" Then 

'筛选 

Cells.AutoFilter 
Range("$A:$U").AutoFilter Field:=15, Criteria1:="=*(111111)*" 

'复制 
Set ar = Cells.SpecialCells(xlCellTypeVisible).Areas 

If ar.Count > 2 Then 


If b.Range("A1") = "" Then 
ar(1).Copy b.Range("A1") 
End If 

For j = 2 To ar.Count - 1 
ar(j).Copy b.Range("A" & b.Columns(1).Find("*", , , , 1, 2).Row + 1) 
'b.Range("A" & Columns(1).Find("*", , , , 1, 2).Row + 1).PasteSpecial Paste:=xlPasteValues 

Next j 

End If 

Set ar = Nothing 

End If 
End With 

Set ws = Nothing 

Call pub_wbClose2(FilesToOpen(x)) 
x = x + 1 



Wend 

ExitHandler: 
Application.ScreenUpdating = True 

ThisWorkbook.Activate 

ThisWorkbook.Sheets(1).Activate 
Exit Sub 

ErrHandler: 
MsgBox Err.Description 
Resume ExitHandler 
End Sub 

Sub test() 
For Each wbook In Workbooks 
Debug.Print wbook.Name 
Next wbook 
End Sub 

Sub pub_wbOpenOrActive(ByVal Wbdir As String, ByVal Wbname As String) 
' 将某Excel文件打开，或者激活 
' 如无此文件，弹出对话框 
For Each wbook In Workbooks 
If wbook.Name = Wbname Then 
wbook.Activate 
Exit Sub 

End If 
Next wbook 

If Len(Dir(Wbdir & Wbname)) > 0 Then ' 存在此文件 
Workbooks.Open Filename:=Wbdir & Wbname 
'Workbooks(Right(WblocalName, Len(WblocalName) - InStrRev(WblocalName, "\"))).Activate
Else 
MsgBox "无法找到 " & Wbdir & Wbname 
Exit Sub 
End If 
End Sub 




Sub pub_wbOpenOrActive2(ByVal wbLocalName As String) 
' 将某Excel文件打开，或者激活 
' 如无此文件，弹出对话框 

For Each wbook In Workbooks 
If wbook.Path & "\" & wbook.Name = wbLocalName Then 
wbook.Activate 
Exit Sub 
End If 
Next wbook 

If Len(Dir(wbLocalName)) > 0 Then ' 存在此文件 
Workbooks.Open Filename:=wbLocalName 
'Workbooks(Right(WblocalName, Len(WblocalName) - InStrRev(WblocalName, "\"))).Activate
Else 
MsgBox "无法找到 " & wbLocalName 
Exit Sub 
End If 

End Sub 



Sub pub_wbClose2(ByVal wbLocalName As String) 
' 将某Excel文件关闭 
' 如无此文件，忽略 
For Each wbook In Workbooks 
If wbook.Path & "\" & wbook.Name = wbLocalName Then 
wbook.Close False 
Exit Sub 
End If 
Next wbook 
End Sub

Sub 合并数据()

Dim n As Integer

Sheets.Add before:=Sheets(1) '新建一个sheet，使得这个sheet用来存放结果，且是第一个sheet
ActiveSheet.Name = "结果"

n = 1

For i = 2 To Sheets.Count '从第二个sheet到最后一个sheet

 For r = 10 To Sheets(i).UsedRange.Item(Sheets(i).UsedRange.Count).Row '从第十行到最后一行

  If Application.WorksheetFunction.CountA(Sheets(i).Range("b" & r & ":d" & r)) = 3 Then '如果第r行的Br、Cr、Dr单元格的内容都不为空

   For c = 2 To 4

   Sheets("结果").Cells(n, c) = Sheets(i).Cells(r, c) '保存到第一个sheet的B、C、D列

   Next c

  n = n + 1

  End If

 Next r

Next i


End Sub

已上传附件，点击按钮即可验证

你说的不少，看不清楚。建议你出示一个样表说说。