Поиск данных в листах и копирование их в отдельные листы - VBA - Ответ 4051937

Option Explicit
 
Sub Procedure_1()
    
    'В константе указываете порядковый номер последнего
        'листа, который должен просматриваться макросом.
    'Это связано с тем, что в ходе работа коды в книгу
        'будут добавляться листы.
    Const mySheetCount As Long = 2
 
    Dim shSheet_1 As Excel.Worksheet
    Dim shLast As Excel.Worksheet
    Dim rngSearch As Excel.Range
    Dim rngFind As Excel.Range, myAddress As String
    Dim myLastRow_1 As Long, myLastRow_2 As Long
    Dim iSheet_1 As Long, jSheet As Long
    
    '1. На время работы кода для ускорения работы кода отключаем:
    'Обновление монитора.
    Application.ScreenUpdating = False
    'События.
    Application.EnableEvents = False
    
    '2. Даём листу "Лист0" имя "shSheet_1".
    'Через это имя будем обращаться к этому листу.
    Set shSheet_1 = Worksheets("Лист0")
    
    'Двигаемся по листу "Лист0" по первому столбцу
        'до первой пустой ячейки.
    'Начиаем двигаться с первой строки.
    iSheet_1 = 1
    Do While IsEmpty(shSheet_1.Cells(iSheet_1, "A")) = False
    
    '3. Чтобы код был проще, сразу создаём лист для текущей ячейки,
    'независимо от того, встретится текст из текущей ячейки на
    'просматриваемых листах или нет.
    'After:=Worksheets(Worksheets.Count) - это последний лист.
    'Одновременно, при создании листа, даём имя "shLast" листу.
    'Через это имя будем обращаться к листу.
        Set shLast = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        
    '4. Даём имя листу в соответствии с данными из ячейки.
    'Только в данном случае нужно учитывать:
    '1) нет ли уже листа с таким именем;
    '2) содержит ли имя допустимые символы;
    '3) длина имени.
    'Я этого ничего не буду учитывать.
        shLast.Name = shSheet_1.Cells(iSheet_1, "A").Value
    
    '5. Подготавливаем номер строки, куда будут вставляться данные на новом листе.
        myLastRow_2 = 1
    
    'В цикле с "jSheet" проходимся по листам, которые надо обработать.
        For jSheet = 2 To mySheetCount Step 1
        
    'Буду использовать команду "Find" для поиска.
    '6. Задаю диапазон поиска, чтобы код работал быстрее и лишнее
    'не просматривал.
    '6.1. Определяю последнюю строку с данными на текущем листе
    'в столбце "A".
            myLastRow_1 = Worksheets(jSheet).Columns("A").Find(What:="?", _
                LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
    '6.2. Даю фрагменту листа, где нужно искать, имя "rngSearch".
    'Здесь вместо "A1" можно указать строку, с которой нужно искать.
            Set rngSearch = Worksheets(jSheet).Range("A1:A" & myLastRow_1)
            
    '7. Осуществляем поиск.
    'After:=rngSearch.Cells(rngSearch.Rows.Count, 1) - здесь указываем,
    'что поиск начинаем с последней ячейки. Это связано с тем, что поиск
    'начинается после указанной ячейки, чтобы данные брались в том порядке,
    'в котором они находятся на листе.
    'LookAt:=xlPart - поиск по частичному совпадению, например "груш".
            Set rngFind = rngSearch.Find(What:=CStr(shSheet_1.Cells(iSheet_1, "A").Value), _
                After:=rngSearch.Cells(rngSearch.Rows.Count, 1), LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                
    'Если слово не будет найдено, то в переменной "rngFind"
    'будет содержаться слово "Nothing".
            If rngFind Is Nothing Then
            
    'Переходим к следующему листу.
                GoTo metka
            
            End If
            
    'Если был результат поиска, то найденной ячейке
    'даётся имя "rngFind". Через это имя можно обращаться к
    'найденной ячейке.
    '8. Запоминаем адрес ячейки, чтобы потом остановить поиск,
    'дойдя до этой же ячейки.
            myAddress = rngFind.Address
            
    'Ведём поиск, пока не вернёмся к первой найденной ячейке.
            Do
            
    '9. Копируем строку на последний лист
                rngFind.EntireRow.Copy Destination:=shLast.Range("A" & myLastRow_2)
                
    '10. Подготавливаем номер строки на последнем листе
    'для следующих данных.
                myLastRow_2 = myLastRow_2 + 1
                
    '11. Ищем дальше в том же диапазоне.
                Set rngFind = rngSearch.FindNext(rngFind)
                
            Loop While rngFind.Address <> myAddress
            
metka:
        
        Next jSheet
    
    '12. Переход к следующей строке.
        iSheet_1 = iSheet_1 + 1
        
    Loop
 
    '13. Включаем то, что отключали в начале работы кода.
    Application.ScreenUpdating = False
    Application.EnableEvents = False
 
End Sub

Option Explicit
Sub разноскаданных()
Dim i As Double
Dim iLastRow1 As Double
Dim K As Double, wsSh As Worksheet
Dim li As Long 'зачистка ячеек в листах (кроме начального)
For li = 2 To Sheets.Count
Sheets(li).UsedRange.Value = Empty
Next li
 
iLastRow1 = Sheets("main").Cells(Rows.Count, 2).End(xlUp).Row 'находим последнюю строку листа main
With Sheets("main")
    On Error Resume Next
    For i = 0 To iLastRow1 'перебираем весь столбец по условию до последней строки
    Set wsSh = Sheets(Trim(.Cells(i + 3, 4).Value))
        If Not wsSh Is Nothing Then
            wsSh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 15).Value = .Cells(i + 3, 1).Resize(, 15).Value
        Else
            Sheets("інші").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 15).Value = .Cells(i + 3, 1).Resize(, 15).Value
        End If
        Set wsSh = Nothing
    Next i
End With
End Sub