Страницы: 1
RSS
VBA Выборочное копирование по названию страницы
 
Есть код, который создает листы по названиям из столбца без повторяющихся значений.
Хотел добавить в код возможность сразу копировать в новые листы значения, которые соответствуют условию.
Что то подобное многоразовой ВПР функции
Из столбца В скопировать ячейку, у которой название группы в стобдце А совпадает с названием соответственно листа
Код
Sub Макрос1()

Application.ScreenUpdating = False
Dim i As Long
For i = 1 To Sheets("1").Range("A" & Rows.Count).End(xlUp).Row
    On Error Resume Next
    Sheets(Sheets("1").Range("A" & i).Value).Select
    If Err And Sheets("1").Range("A" & i) <> "" Then
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = Sheets("1").Range("A" & i)
    End If
Next i
Worksheets("1").Activate
Application.ScreenUpdatind = True
End Sub
Изменено: Secret - 13.12.2018 13:25:47
 
Данные в примере всегда сгруппированы по именам листов? Где конкретно на добавленных листах нужно располагать скопированные данные?
Кому решение нужно - тот пример и рисует.
 
Изначально дано всегда два столбца Название группы, Имя. Листы создаются на основании данных из 1 столбца.
На созданных листах добавить просто списком имена, соответствующие группе в названии листа.
 
Я, вроде, по-русски пишу...
Давайте ещё раз:
Данные в примере всегда сгруппированы по именам листов?

Где конкретно на добавленных листах нужно располагать скопированные данные?

З.Ы. Если словами сложно - покажите в файле-примере как могут быть исходные данные и куда конкретно вставляем при копировании.
Изменено: Пытливый - 13.12.2018 13:55:33
Кому решение нужно - тот пример и рисует.
 
ДА, листы формируются по порядку из 1 столбца с данными. В каком порядке там будут выставлены группы, соответственно так и создадутся листы.
При копировании вставляем в нужный лист (пусть это будет столбец А), в виде списка.
Изначально в книге дан только один лист с данными.
 
Код
Sub Макрос1()

Application.ScreenUpdating = False
Dim i As Long
For i = 1 To Sheets("1").Range("A" & Rows.Count).End(xlUp).Row
    On Error Resume Next
    Sheets(Sheets("1").Range("A" & i).Value).Select
    If Err And Sheets("1").Range("A" & i) <> "" Then
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = Sheets("1").Range("A" & i)
    End If
    CurRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
    ActiveSheet.Cells(CurRow, 1).Value = Sheets("1").Cells(i, 2).Value
Next i
Worksheets("1").Activate
Application.ScreenUpdatind = True
End Sub

например так пойдет?
Изменено: Melkior - 13.12.2018 14:46:22
Страницы: 1
Наверх