Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Скрипт поиска значений и перенос строк на новый лист
 
#1
26.07.2022 20:04:40
День добрый уважаемые форумчане!
Помогите пожалуйста упростить данный макрос:
Код
Sub TEST()
Application.ScreenUpdating = False
rest_1 = "Атриум"
rest_2 = "Большая Никитская"
rest_3 = "Геленджик"

Dim iCell As Range, Priznak As Variant

   Sheets(rest_1).Range("A6:I10000").Clear
   Priznak = rest_1
   For Each iCell In Range("B2", [B2].End(xlDown)) 'цикл по всем ячейкам B2 и ниже
       If iCell = Priznak Then
           With Sheets(rest_1) 'копируем Атриум
               iCell.EntireRow.Copy Destination:=.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
           End With
       End If
   Next iCell
   
   Sheets(rest_2).Range("A6:I10000").Clear
   Priznak = rest_2
   For Each iCell In Range("B2", [B2].End(xlDown)) 'цикл по всем ячейкам B2 и ниже
       If iCell = Priznak Then
           With Sheets(rest_2) 'копируем Большую Никитскую
               iCell.EntireRow.Copy Destination:=.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
           End With
       End If
   Next iCell
   
   Sheets(rest_3).Range("A6:I10000").Clear
   Priznak = rest_3
   For Each iCell In Range("B2", [B2].End(xlDown)) 'цикл по всем ячейкам B2 и ниже
       If iCell = Priznak Then
           With Sheets(rest_3) 'копируем Геленджик
               iCell.EntireRow.Copy Destination:=.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
           End With
       End If
   Next iCell
   
Application.ScreenUpdating = True
End Sub

Собственно, хочу массив ("Атриум", "Большая Никитская", "Геленджик") и 1 цикл, который ищет на листе, где запущен макрос, строки по столбцу B со значением первого элемента массива и переносит их на лист, название которого = первому элементу массива и т.д.
Элементы массива = значению столбца B и = названию листа.
Спасибо )

P.S. прошу модераторов переименовать тему: "Скрипт поиска значений и перенос строк на новый лист"
Изменено: Юрий М - 27.07.2022 00:09:57
 
 
 
#2
26.07.2022 20:51:32
Андрей Коваленко,  для начала ознакомьтесь с правилами. Затем:
1. Предложите новое название темы, из которого будет понятна задача/проблема - модераторы поменяют.
2. Прикрепите к стартовому сообщению небольшой файл-пример.
3. Код оформите соответствующим тегом: для этого используйте кнопку <...>
 
 
 
#3
26.07.2022 21:05:54
Код
Sub TEST()
  Application.ScreenUpdating = False
  Dim rest, sh&, iCell As Range
  rest = Array("Атриум", "Большая Никитская", "Геленджик")
  For sh = 0 To UBound(rest)
    With Worksheets(rest(sh))
      .Range("A6:I10000").Clear
      For Each iCell In .Range("B2", .[B2].End(xlDown)) 'цикл по всем ячейкам B2 и ниже
        If iCell = rest(sh) Then
          iCell.EntireRow.Copy .Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End If
      Next iCell
    End With
  Next
  Application.ScreenUpdating = True
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#4
26.07.2022 21:35:37
Ігор Гончаренко, спасибо, большое, за помощь. Листы очищаются, но данные не копируются. Приложил к первому посту пример. Если не сложно, посмотрите, пожалуйста
 
 
 
#5
26.07.2022 21:59:30
Код
iCell.EntireRow.Copy Destination:=.Cells(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, "A")
 
 
 
#6
26.07.2022 22:03:53
Код
Sub TEST2()
  Application.ScreenUpdating = False
  Dim s, sh, i&, iCell As Range
  s = "Атриум,Большая Никитская,Геленджик": sh = Split(s, ",")
  For i = 0 To UBound(sh)
    Worksheets(sh(i)).Range("A6:I10000").Clear
  Next
  For Each iCell In Range("B2", [B2].End(xlDown)) 'цикл по всем ячейкам B2 и ниже
    If InStr(s, iCell) Then _
      iCell.EntireRow.Copy Worksheets(iCell.Value).Cells(Rows.Count, 1).End(xlUp).Offset(1)
  Next
  Application.ScreenUpdating = True
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#7
27.07.2022 14:52:08
Ігор Гончаренко, Kuzmich, спасибо!
 
 
 
#8
27.07.2022 15:10:51
Андрей Коваленко, желательно добавить проверку наличия в книге определенного листа
Код
Sub TEST_()
  Application.ScreenUpdating = False
  Dim rest, sh&, iCell As Range
  rest = Array("Атриум", "Большая Никитская", "Геленджик", "Анапа")
  For sh = 0 To UBound(rest)
   If SheetExist(CStr(rest(sh))) Then
    With Worksheets(rest(sh))
      .Range("A6:I10000").Clear
      For Each iCell In Range("B2", [B2].End(xlDown)) 'цикл по всем ячейкам B2 и ниже
        If iCell = rest(sh) Then
          iCell.EntireRow.Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        End If
      Next iCell
    End With
   Else
     MsgBox "В книге нет листа с именем: " & rest(sh)
   End If
  Next
  Application.ScreenUpdating = True
End Sub
Function SheetExist(iName As String) As Boolean
    On Error Resume Next
    With Worksheets(iName): End With
    SheetExist = (Err = 0)
End Function
 
 
 
Страницы: 1
Наверх