Страницы: 1
RSS
Скопировать строку на новый лист, если ячейка содержит определенные значения из справочника
 
Добрый день.
Есть таблица, которая содержит более 40000 строк. Надо полностью скопировать на новый лист только те строки, у которых текст в ячейках в колонке ISBN начинается  с кодов 978-5-04-, 978-5-699-, 978-5-00117-, 978-5-00146-, 978-5-00169-
Есть макрос, который все это делает
Код
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub ISBN()
    Dim iTimer As Single
    iTimer = Timer
     
Dim i&
For i = 1 To Cells(Rows.Count, 11).End(xlUp).Row
If Cells(i, 11) Like "978-5-04-*" Or Cells(i, 11) Like "978-5-699-*" Or Cells(i, 11) Like "978-5-00117-*" Or Cells(i, 11) Like "978-5-00146-*" Or Cells(i, 11) Like "978-5-00169-*" Then
Rows(i).Copy
Sheets("Отбор").Cells(Sheets("Отбор").Cells(Rows.Count, 11).End(xlUp).Row + 1, 1).PasteSpecial
End If
Next
Application.CutCopyMode = False
     
   MsgBox "отбор завершен." & vbCrLf & "Время выполнения макроса  " & Format((Timer - iTimer) / 86400, "Long Time"), vbInformation, "ОТБОР ISBN"
 
 
End Sub
Сначала у меня было 2 варианта отбора, теперь 5, и это не предел.
Я все условия отбора включил в макрос, а можно сделать так, чтобы условия отбора выбирались из справочника, который находиться на отдельном листе? Тогда при изменении условия отбора можно будет просто добавить в справочник новые данные.
Исходный файл и результат работы макроса прилагаются.
Спасибо!
 
Попробуйте:
Код
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub ISBN()
    Dim iTimer      As Single
    iTimer = Timer
    Dim lr As Long, j As Long
    Dim arr         As Variant
    Dim i&
    lr = Worksheets("Справочник").Cells(Rows.Count, 1).End(xlUp).Row
    arr = Worksheets("Справочник").Range("A2:" & "A" & lr).Value
 
    For i = 1 To Cells(Rows.Count, 11).End(xlUp).Row
        For j = LBound(arr) To UBound(arr)
            If Cells(i, 11) Like arr(j, 1) & "*" Then
                Rows(i).Copy
                Sheets("Отбор").Cells(Sheets("Отбор").Cells(Rows.Count, 11).End(xlUp).Row + 1, 1).PasteSpecial
            End If
        Next j
    Next
    Application.CutCopyMode = False
 
    MsgBox "отбор завершен." & vbCrLf & "Время выполнения макроса  " & Format((Timer - iTimer) / 86400, "Long Time"), vbInformation, "ОТБОР ISBN"
 
End Sub
Изменено: Behruz A.N. - 26.03.2022 09:44:26
Вредить легко, помогать трудно.
 
karlson7, возможно, подойдет решение в PQ (обновляется по кнопке Обновить все на вкладке Данные):
Код
1
2
3
4
5
6
let
  data       = Excel.CurrentWorkbook(){[ Name = "data" ]}[Content],
  filterList = List.Buffer ( Excel.CurrentWorkbook(){[ Name = "filter" ]}[Content][Начало кода для отбора] ),
  result     = Table.SelectRows ( data, ( r ) => List.Contains ( filterList, r[ISBN], ( s, c ) => Text.StartsWith ( c, s ) ) )
in
  result
 
Behruz A.N.,
спасибо! То, что надо
Изменено: karlson7 - 26.03.2022 22:00:36
Страницы: 1
Читают тему
Loading...