Выберите данные на основе критериев, а затем скопируйте строки, соответствующие определенному критерию

Question

У меня есть мастер-файл, который содержит временные интервалы с соответствующими деталями.Колонка L называется "Slot Status".Столбец A - это уникальное число от 1 до 1000 (например, A2=1, A3=2, A3=4 ...).

На рабочем листе "UnSlotted" пользователи обновят информацию, чтобы заполнить недостающую информацию, что приведет к изменению ячеек в столбце M (статус слота) с "Info Required" на "OK".

---

В настоящее время я использую приведенный ниже макрос для автофильтрации столбца L для ячеек, содержащих «информация требуется».Затем он копирует найденные данные в рабочую таблицу с названием "UnSlotted".

Сейчас я ищу макрос, который выберет строки, в которых столбец M содержит "OK", и скопирует их в "Master Sheet" в строке, соответствующей соответствующему уникальному номеру (столбец A).
EGИдентификатор уникального номера - "37", скопируйте эту строку в таблицу «Мастер» в строке, где сопоставляется столбец Идентификатор уникального номера.

Sub TestTHIS()

    Sheets("UnSlotted").Range("A6:M9999").Select
    Selection.ClearContents

    Dim ws As Worksheet
    Set ws = Application.Worksheets("Master File")

    Dim data_end_row_number As Integer
    data_end_row_number = ws.Range("a2").End(xlDown).Rows.Count

    ws.Range("A1:M1").AutoFilter field:=13, Criteria1:="Info required", VisibleDropDown:=True

    ws.Range("A2:M9999" & data_end_row_number).SpecialCells(xlCellTypeVisible).Copy
    Sheets("UnSlotted").Range("A6").PasteSpecial

    Worksheets("Master File").ShowAllData

End Sub

Answer 1

Это поможет.

Возможно, вам потребуется изменить столбцы, на которых должна основываться фильтрация («ОК»).Прямо сейчас это столбец M для листа "UnSlotted".Вы также можете изменить размер строки, которая должна быть скопирована, (прямо сейчас это столбец A - AA.

Код VBA:

Sub CompareCopyFilter()

Dim CopyFromWorkbook As Workbook
Set CopyFromWorkbook = Workbooks("Master File.xlsm") 'Name the Workbook that should be copied from
Dim CopyToWorkbook As Workbook
Set CopyToWorkbook = Workbooks("Master File.xlsm") 'Name the Workbook that should be copied to
Dim CopyFromSheet As Worksheet
Set CopyFromSheet = CopyFromWorkbook.Worksheets("UnSlotted") 'Name the Worksheet that should be copied from
Dim CopyToSheet As Worksheet
Set CopyToSheet = CopyToWorkbook.Worksheets("Master File") 'Name the Worksheet that should be copied to
Dim lrow As Long
Dim lrowCompare As Long
Dim lrowPasteCopyTo As Long
Dim Val As String
Dim ValCompare As String
Dim j As Long
Dim Test As String
Dim Test2 As String

Dim cl As Range
Dim rng As Range
Dim CurrentRow As Long

lrow = CopyFromSheet.Cells(Rows.Count, "A").End(xlUp).Row 'Find last row in sheet that should be copied from
lrowCompare = CopyToSheet.Cells(Rows.Count, "A").End(xlUp).Row 'Find last row in sheet that should be copied from

CopyFromSheet.Activate 'Activate From Sheet
Set rng = CopyFromSheet.Range(Cells(2, 1), Cells(lrow, 1)) 'Set Range to apply filter on
CopyFromSheet.Range("A1:M1").AutoFilter Field:=13, Criteria1:="OK", VisibleDropDown:=True 'Filter Column M, based on criteria "OK" in the sheet you want to copy from

For Each cl In rng.SpecialCells(xlCellTypeVisible) 'Loop throug all visible cells in range
    CurrentRow = cl.Row 'Row number for current cell in filtered filter
    Val = CopyFromSheet.Cells(CurrentRow, "A").Value 'Get the value from the cell you want to copy from
    For j = 2 To lrowCompare 'Loop through the value in the sheet you want to copy to
        ValCompare = CopyToSheet.Cells(j, "A").Value 'Get the value from the cell you want to copy to
        If Val = ValCompare Then 'Compare the values between the two workbooks, if the match (exact match) then
            CopyFromSheet.Activate
            CopyFromSheet.Range(Cells(CurrentRow, "A"), Cells(CurrentRow, "AA")).Copy 'Copy row from Column A to Column AA
            CopyToSheet.Activate 'Activate workbook to paste into
            CopyToSheet.Range(Cells(j, "A"), Cells(j, "AA")).PasteSpecial xlPasteValues 'Paste values into range.
        End If
    Next j
Next cl
Application.CutCopyMode = False 'Deselect any copy selection
End Sub

Мой пример настройки:

Рабочий лист, с которого необходимо скопировать.

Рабочий лист, с которого необходимо скопировать.