search多个工作表，然后将where列A> 0的所有行复制到指定的工作表中

问候，

我已经看了很多代码来帮助我做这件事，虽然我发现了几个暗示，也许这是我对vba的经验不足，但我还没有能够修改任何东西为我工作。 我有一个数量，部分，描述的工作表的工作簿。 数量在列a中。 每个工作簿的前三行是一个标题。 我正在寻找在我的“摘要”工作表中search所有其他工作表的代码，并汇总了汇总表中的所有数量，部分和描述信息（列a，b和c），所以基本上我最终数量大于0的每个项目的摘要页面上的列表，从行4开始。任何提示或build议将不胜感激。

非常感谢，威廉

Answer 1

当我看到eggplant_parm已经回答你的时候，我试图解决这个问题。 顺便说一下，这是我的解决scheme，与他的解决scheme非常相似。

Option Explicit Sub copy_info() Dim i As Long, j As Long, lastRow As Long Dim sh As Worksheet With Sheets("Summary") .Cells.Clear .Range("A1") = "Quantity" .Range("B1") = "Parts" .Range("C1") = "Description" .Range("D1") = "Sheet name" .Range("A1:D1").Font.Bold = True End With j = 2 For Each sh In ActiveWorkbook.Sheets If sh.Name <> "Summary" Then lastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row For i = 4 To lastRow If sh.Range("A" & i) > 0 Then sh.Range("a" & i & ":c" & i).Copy Destination:=Worksheets("Summary").Range("A" & j) Sheets("Summary").Range("D" & j) = sh.Name j = j + 1 End If Next i End If Next sh Sheets("Summary").Columns("A:D").AutoFit End Sub 

Answer 2

这应该工作，如果我正确理解你的设置。

 Sub GetParts() Application.ScreenUpdating = False Dim W As Worksheet, r As Single, i As Single i = 4 For Each W In ThisWorkbook.Worksheets If W.Name <> "Summary" Then For r = 4 To W.Cells(Rows.Count, 1).End(xlUp).Row If W.Cells(r, 1) > 0 Then Range(W.Cells(r, 1), W.Cells(r, 3)).Copy _ ThisWorkbook.Worksheets("Summary").Cells(i, 1) i = i + 1 End If Next r End If Next W End Sub 

Answer 3

这有点长，但是，我认为这种方法将允许你更容易地修改代码，我希望它可以帮助。

 Public Sub main() 'Using PrintCollection,ReadCollection and FilterCollection PrintColl Ws:="Sheet3", _ coll:=FilterColl( _ coll:=ReadColl( _ WSs:=Array("Sheet1", "Sheet2"), _ fRow:=4, _ lRow:=-1, _ fCol:=1, _ lCol:=2)), _ fRow:=1, _ fCol:=3 End Sub 'Function to determine if table(index) should be included in the result. Function MyFilter(ByRef table As Variant, ByVal index As Integer) As Boolean If table(index, 1) > 0 Then MyFilter = True Else MyFilter = False End If End Function 'Takes an array of worksheet names and 4 parameters that represent a range 'It asumes that Cols are adjacent and the data starts in the same row 'Pass a negative value to lRow to look down the first Col of every worksheet 'returns a Collection with WS names as key and arrays with the range values Function ReadColl(ByRef WSs As Variant, _ ByVal fRow As Integer, ByVal lRow As Integer, _ ByVal fCol As Integer, ByVal lCol As Integer) As collection Dim coll As New collection Dim l As Integer For i = 0 To UBound(WSs, 1) If lRow < 0 Then l = LastNumber(WSs(i), fRow, fCol) Else l = lRow End If coll.Add ReadTbl(WSs(i), fRow, l, fCol, lCol), WSs(i) Next i Set ReadColl = coll End Function 'Read the values in a WS into an array Function ReadTbl(ByVal Ws As String, _ ByVal fRow As Integer, ByVal lRow As Integer, _ ByVal fCol As Integer, ByVal lCol As Integer) As Variant ActiveWorkbook.Worksheets(Ws).Select Range(Cells(fRow, fCol), Cells(lRow, lCol)).Select ReadTbl = Selection.Value End Function 'Filter every table inside the collection supplied Function FilterColl(ByRef coll As collection) As collection Dim filtered As New collection Dim table As Variant For Each table In coll filtered.Add (FilterTbl(table)) Next table Set FilterColl = filtered End Function 'Returns a new table composed by elements that make MyFilter true Function FilterTbl(ByRef table As Variant) As Variant Dim filtered As New collection Dim elem() As Variant ReDim elem(1 To UBound(table, 2)) For i = 1 To UBound(table, 1) If MyFilter(table, i) = True Then For j = 1 To UBound(table, 2) elem(j) = table(i, j) Next j filtered.Add elem, CStr(i) End If Next i FilterTbl = CollToTbl(filtered) End Function 'Auxiliary function to solve array limitations in vba Function CollToTbl(ByRef coll As collection) As Variant If coll.Count > 0 Then Dim ary() As Variant Dim item As Variant Dim nCols As Integer nCols = UBound(coll(1), 1) ReDim ary(1 To coll.Count, 1 To nCols) For i = 1 To coll.Count For j = 1 To nCols ary(i, j) = coll(i)(j) Next j Next i CollToTbl = ary End If End Function 'Takes Ws, a collection, and the first position where the result is expected Sub PrintColl(ByVal Ws As String, ByRef coll As collection, _ ByVal fRow As Integer, ByVal fCol As Integer) Dim pos As Integer pos = fRow ActiveWorkbook.Worksheets(Ws).Select Selection.ClearContents For i = 1 To coll.Count PrintTbl Ws, coll(i), pos, fCol pos = pos + UBound(coll(i), 1) Next i End Sub 'Same as before except it outputs an specific table Sub PrintTbl(ByVal Ws As String, ByRef table As Variant, _ ByVal fRow As Integer, ByVal fCol As Integer) ActiveWorkbook.Worksheets(Ws).Select Range(Cells(fRow, fCol), _ Cells(fRow + UBound(table, 1) - 1, UBound(table, 2))).Select Selection.Value = table End Sub 'Iterates Col in the WS starting in fRow until IsNumber returns false Function LastNumber(ByVal Ws As String, _ ByVal fRow As Integer, ByVal Col As Integer) As Integer ActiveWorkbook.Worksheets(Ws).Select While WorksheetFunction.IsNumber(Cells(fRow, Col).Value) fRow = fRow + 1 Wend LastNumber = fRow - 1 End Function