У меня есть несколько листов в книге Excel.Мне нужно отсканировать все эти листы одним нажатием кнопки и выбрать конкретные значения из листов

Question

У меня есть следующие таблицы на отдельных листах (но в одной и той же книге):

Лист 1

Лист 2

Лист 3

В листе 4 мне нужно нажать кнопку. Эта кнопка отсканирует листы 1, 2 и 3 и предоставит список элементов, для которых столбец «Постоянный» имеет значение «Нет». Это должен быть один список на листе 4.

Ожидаемый лист 4:

Я не уверен, с чего начать.

Answer 1

Это далеко не идеальное решение, и ему по-прежнему требуется некоторая обработка ошибок для решения повседневных проблем ... однако это должно дать вам хорошую отправную точку в том, как манипулировать вашими данными, и делать это без чтения туда-сюда из электронная таблица несколько раз (хотя для пары строк это не имеет значения, для нескольких тредов это имеет значение).

Option Explicit

Sub getNonPermanents()

Dim wb As Workbook: Set wb = ActiveWorkbook         'or ThisWorkbook, or the name of the workbook where data is
Dim ws As Worksheet
Dim R As Long, C As Long, X As Long
Dim lRow As Long

Dim arrData
Dim arrNonPerm() As String: ReDim arrNonPerm(1 To 3, 1 To 1)

    For Each ws In wb.Worksheets()
        If ws.Name = "Sheet1" Or ws.Name = "Sheet2" Or ws.Name = "Sheet3" Then  'Or could just be ws.Name <> "Sheet 4", and/or other more elegant ways to deal with this
            lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row                     'Get the last row in the current sheet

            arrData = ws.Range(ws.Cells(2, 1), ws.Cells(lRow, 3))               'Allocate all data to an array

            For R = LBound(arrData) To UBound(arrData)                          'Loop through the data, and if any are "No"....
                If arrData(R, 3) = "No" Then
                    X = X + 1
                    ReDim Preserve arrNonPerm(1 To 3, 1 To X)                   'Increase the array as needed
                    For C = LBound(arrData, 2) To UBound(arrData, 2)
                        arrNonPerm(C, X) = arrData(R, C)                        'Allocate to the non perm array
                    Next C
                End If
            Next R
        End If
    Next ws

    Erase arrData
    ReDim arrData(LBound(arrNonPerm, 2) To UBound(arrNonPerm, 2), LBound(arrNonPerm) To UBound(arrNonPerm))

    For R = LBound(arrNonPerm, 2) To UBound(arrNonPerm, 2)                      'Reallocate the data to an array to be ready to put it back in the sheet
        For C = LBound(arrNonPerm) To UBound(arrNonPerm)
            arrData(C, R) = arrNonPerm(R, C)
        Next C
    Next R

    With wb.Worksheets("Sheet4")
        lRow = .Cells(.Rows.Count, 1).End(xlUp).row
        .Range(.Cells(lRow + 1, 1), .Cells(lRow + UBound(arrData), 3)) = arrData    'Add the data at the end of existing data (i.e. headers the very least).
    End With

End Sub

Answer 2

Вы можете попробовать:

Option Explicit

Sub test()

    Dim ws As Worksheet
    Dim LastrowWS As Long, LastrowS4 As Long, i As Long

    For Each ws In ThisWorkbook.Worksheets

        If ws.name <> "Sheet4" Then

            With ws

                LastrowWS = .Cells(.Rows.Count, "A").End(xlUp).Row

                For i = 2 To LastrowWS

                    If .Range("C" & i).Value = "No" Then

                        .Range("A" & i & ":C" & i).Copy

                        With ThisWorkbook.Worksheets("Sheet4")

                            LastrowS4 = .Cells(.Rows.Count, "A").End(xlUp).Row

                            .Range("A" & LastrowS4 + 1).PasteSpecial xlPasteValues

                        End With

                    End If

                Next i

            End With

        End If

    Next

End Sub