Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Цикл. Извлечь все значения по той или иной компании
 
#1
30.07.2021 11:06:20
Всем добрый день!
Есть задача - из выгрузки отфильтровать все предприятия по очереди, которые содержат в названии слово "Ромашка", "Колокольчик", "Одуванчик" и тд и перенести их в другую книгу по отдельности каждое, и так по всем до тех пор, пока строки в выгрузке не закончатся. Файл с примером приложу.

Суть в чем, мне нужно посчитать кол-во пользователей по каждому предприятию в этой выгрузке. Каждое предприятие должно быть в отдельном файле, в котором будет построена сводная таблица. Я не пишу макросы, но логику более менее понимаю, что сделать это можно циклом. Вычленить одно предприятие я могу, но как написать код таким образом, чтобы не перечислять сотни названий? Ниже пример на одном предприятии. Как это превратить в цикл?

Макрос для построения сводных я написала, нужен только цикл по фильтру и копипасту.
Код
'отбор по предприятиям
 ActiveSheet.Range(Selection, Selection.End(xlUp)).AutoFilter Field:=19, Criteria1:= _
        "=*Ромашка*", Operator:=xlAnd
 Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Sheets("Лист1").Select
    Sheets("Лист1").Name = "Ромашка"
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
Изменено: vikttur - 30.07.2021 12:14:58
 
 
 
#2
30.07.2021 12:16:18
Код
Sub CopyManyItem()
    Dim col As New Collection
    col.Add "Ромашка"
    col.Add "Колокольчик"
    col.Add "Одуванчик"

    Dim romashka As Variant
    For Each romashka In col
        CopyOneItem romashka
    Next
End Sub

Sub CopyOneItem(ByVal romashka As String)
    'отбор по предприятиям
    ActiveSheet.Range(Selection, Selection.End(xlUp)).AutoFilter Field:=19, Criteria1:="=*" & romashka & "*", Operator:=xlAnd
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    Sheets("Лист1").Select
    Sheets("Лист1").Name = ChangeSheetName(romashka)
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
End Sub

Function ChangeSheetName(ByVal s) As String
    Const c = "@#$%&()+~`':;.,|/\*?[]"""
    Dim i As Byte
    s = Left(s, 31)
    For i = 1 To Len(c)
        s = Replace(s, Mid(c, i, 1), " ")
    Next
    ChangeSheetName = s
End Function
Изменено: МатросНаЗебре - 30.07.2021 12:23:21 (ChangeSheetName)
 
 
 
#3
30.07.2021 12:51:50
для коллекции:
Разделение таблицы по листам
Преимущества сводной по Модели Данных
Распределяем список по наборам
Массовая замена текста формулами
Массовая замена текста в Power Query функцией List.Accumulate

Возможно, идеи из этих статей пригодятся Вам для решения собственных задач
 
 
 
#4
30.07.2021 15:24:39
Цитата
МатросНаЗебре написал:
Sheets("Лист1").Name = ChangeSheetName(romashka)    Range("A1").Select    ActiveSheet.Paste
Добрый день! Тестирую макрос, правильно понимаю, что в данной команде скопированное пытается вставиться на этот же лист, потому как выходит ошибка, что диапазоны перекликаются и имеют разную область выделения, т.к. продолжает работу с активным листом ?
 
 
 
#5
30.07.2021 15:41:22
Понимаете правильно.
Так должно быть получше, но это не точно.
Код
Sub CopyOneItem(ByVal romashka As String)
    'отбор по предприятиям
    ActiveSheet.Range(Selection, Selection.End(xlUp)).AutoFilter Field:=19, Criteria1:="=*" & romashka & "*", Operator:=xlAnd
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    
    Set sh1 = ActiveSheet
    Selection.Copy
    Set sh2 = Sheets.Add(After:=ActiveSheet)
    sh2.Select  'не нужно
    sh2.Name = ChangeSheetName(romashka)
    Range("A1").Select
    ActiveSheet.Paste
    
    sh1.Select
    Application.CutCopyMode = False
End Sub
Изменено: МатросНаЗебре - 30.07.2021 15:41:46
 
 
 
#6
03.08.2021 13:32:36
Цитата
МатросНаЗебре написал:
Так должно быть получше
Стало лучше!) работает отлично. Спасибо!  :)  
 
 
 
Страницы: 1
Наверх