День добрый уважаемые форумчане! Помогите пожалуйста упростить данный макрос:
Код
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. прошу модераторов переименовать тему: "Скрипт поиска значений и перенос строк на новый лист"
Андрей Коваленко, для начала ознакомьтесь с правилами. Затем: 1. Предложите новое название темы, из которого будет понятна задача/проблема - модераторы поменяют. 2. Прикрепите к стартовому сообщению небольшой файл-пример. 3. Код оформите соответствующим тегом: для этого используйте кнопку <...>
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
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
Ігор Гончаренко, спасибо, большое, за помощь. Листы очищаются, но данные не копируются. Приложил к первому посту пример. Если не сложно, посмотрите, пожалуйста
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
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
Андрей Коваленко, желательно добавить проверку наличия в книге определенного листа
Код
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