Выполните поиск по нескольким листам и скопируйте все строки со столбцом где A> 0 на указанный лист

Question

Привет,

Я довольно долго искал код, который поможет мне сделать это, и хотя я нашел несколько фрагментов, которые намекают на это, возможно, это моя неопытность с vba, но я не имеюЯ не смог ничего изменить, чтобы работать на меня.У меня есть рабочая тетрадь с несколькими таблицами величин, деталей, описаний.Количество в колонке а.Первые 3 строки каждой книги являются заголовком.Мне нужно, чтобы на моем листе «Сводка» был код, который ищет все другие листы и компилирует всю информацию о количестве, деталях и описании (столбцы a, b и c) на листе «Сводка», поэтому в основном я получаюсписок на итоговой странице каждого товара с количеством больше 0, начиная со строки 4. Будем весьма благодарны за любые подсказки или предложения.

Спасибо большое, Уильям

Answer 1

Я пытался решить проблему, когда вижу, что eggplant_parm уже ответил вам.Кстати, это мое решение, очень похожее на его.

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

это немного долго, но, я думаю, этот подход позволит вам легче модифицировать код Надеюсь, это поможет.

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

Answer 3

Это должно работать, если я правильно понимаю ваши настройки.

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