Страницы: 1 2 След.
RSS
Разнесение данных по отдельным листам
 
Собственно вопрос в заголовке
Поиском конечно прошелся, но подходящего именно мне варианта не смог найти

Суть
Есть лист в котором есть несколько групп однотипных (но не одинаковых по количеству строк) данных, имеющие в начале и в конце определенные "слова-маркеры"

Например:

START
набор данных
набор данных
набор данных
...
END

START
набор данных
набор данных
набор данных
...
END

Задача все строки между START и END переместить в новый лист, а новый лист переименовать по имени находящемуся в определенной ячейке этого листа (к примеру А6)

Что-то у меня не выходит каменный цветок)) В PLEX подходящего решения также не нашел

p.s. "слова-маркеры" при необходимости можно настроить - т.е. сделать любой текст/символ, разместить маркер в начале группы или в конце или там и там
p.p.s  сами "маркеры" как данные не принципиальны, то есть носят сугубо вспомогательный смысл их переносить не обязательно

Буду признателен за подсказку)
 
Что то не совсем понятно, вам по сути нужно просто скопировать весь диапазон данных, за исключением слов маркеров на новый лист? Или же вам нужно для каждого из диапазона данных сделать отдельный лист?  
 
valex470, без примера будет туго вам помочь
 
ivanok_v2,
Цитата
ivanok_v2 написал:
без примера будет туго вам помочь
я бы сказал чуть иначе - без примера вам будет туго получить помощь =)
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
есть несколько групп однотипных (но не одинаковых по количеству строк) данных
Цитата
а новый лист переименовать по имени находящемуся в определенной ячейке этого листа (к примеру А6)
Так групп-то несколько, значит и листов будет несколько. Какие названия им давать?
И пример сделайте, не поленитесь.
 
первый шаг через PQ создаете доп столбец
второй шаг через PLEX разобрать  
В жизни нет ничего невозможного! Есть только недостаток знаний и умений.
 
Всем спасибо за желание помочь)
Постараюсь уточнить (пример во вложении)
В одном блоке данных (между START и END) количество столбцов одинаково, но количество строк разное (поэтому к количеству строк не привязаться)

Задача каждый блок данных между START и END перенести на новый лист в этой же книге и (полагаю эту операцию надо делать после переноса) переименовать лист по значению из определенной ячейки (к примеру А6)

Сами маркеры переносить не обязательно
Сами данные формируются в стороннем ПО (через буфер обмена в txt формате) и, как я уже сказал, "маркеры" можно сконфигурировать - то есть (если достаточно одного маркера) сделать только один маркер в начале или в конце или сделать его в виде спец-символа
Но маркеры всегда будут одинаковыми (то есть не получится сделать перед каждым блоком разный маркер типа START1,  START2 и т.п)

P.s. Excel 2016 если что
 
Код
Sub StartEnd()
Dim iLastRow As Long
Dim FoundCell As Range
Dim FAdr As String
Dim n As Integer
Dim List1 As Worksheet
Dim FRow As Long
Dim ERow As Long
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   Set List1 = ThisWorkbook.Worksheets("Лист1")
 With Range("A1:A" & iLastRow)
    Set FoundCell = .Find("START", .Cells(.Cells.Count), xlValues, xlWhole, , xlNext)
     If Not FoundCell Is Nothing Then
       FAdr = FoundCell.Address
       n = 1
      Do
       FRow = FoundCell.Row + 1
       ERow = Cells(FRow, "A").End(xlDown).Row - 1
       Set FoundCell = .FindNext(FoundCell)
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = "Набор_" & n
        List1.Range(List1.Cells(FRow, "A"), List1.Cells(ERow, "C")).Copy Range("A1")
        n = n + 1
        List1.Activate
      Loop While FoundCell.Address <> FAdr
     End If
 End With
End Sub
 
Kuzmich,
Спасибо
Почти сработало, но макрос почему-то переносит только первые три столбца, а у меня количество столбцов бывает разное, в зависимости от шаблона выгрузки из стороннего ПО (просто везде будут "маркеры")
Можно сделать так, что бы копировались все строки от начального маркера до конечного независимо от количества столбцов?

И на счет пререименования листов - нарастающий номер мысль интересная, но в моём случае не совсем подходит - надо брать имя из определенной ячейки для идентификации

Что-то вроде:
For Each Sh In Worksheets
Sh.Name = Sh.Range("A6").Text

нашел где-то здесь же на форуме, но изменить Ваш скрипт почему-то не получается - знаний не хватает))
 
Цитата
но макрос почему-то переносит только первые три столбца
Диапазон для переноса определяется строкой, где  "C" как раз третий столбец
Код
List1.Range(List1.Cells(FRow, "A"), List1.Cells(ERow, "C")).Copy Range("A1")

Цитата
брать имя из определенной ячейки для идентификации
Я уже писал, так  как групп-то несколько, значит и листов будет несколько. Для каждого должно быть свое имя.

 
Kuzmich, я бы для универсальности написал
Код
With Worksheets(1)
.Range(.Rows(FRow), .Rows(ERow)).Copy Rows(1)
End With
Изменено: StoTisteg - 04.09.2018 13:37:55
 
Цитата
Kuzmich написал:
Я уже писал, так  как групп-то несколько, значит и листов будет несколько. Для каждого должно быть свое имя.
Возможно я Вас не совсем правильно понял, но в общем-то не вижу противоречий)
Просто на каждом получившемся листе в определенной ячейке будет находиться уникальное значение (то есть совпадений не будет), по которому можно будет понять, что на этом листе находятся данные, соответствующие данному идентификатору (т.е. имени листа)

Цитата
Kuzmich написал:
Диапазон для переноса определяется строкой, где  "C" как раз третий столбец
Понял, буду знать где поправить при необходимости)
 
valex470, ну вот и поведайте нам, в какой именно, чтобы могли его взять для имени листа :) Или Вас устроит перебирать все листы в поисках нужного?
 
Цитата
Просто на каждом получившемся листе в определенной ячейке будет находиться уникальное значение
Кто его туда будет вставлять?
Это уникальное значение должно находится на первом листе, чтобы макрос в процессе создания очередного листа
мог брать это имя. Можно использовать метку "START1", "START2" и т.д.
 
StoTisteg, для универсальности можно использовать строку
Код
List1.Rows(FRow & ":" & ERow).Copy Range("A1")
вместо
Код
List1.Range(List1.Cells(FRow, "A"), List1.Cells(ERow, "C")).Copy Range("A1")
 
Цитата
StoTisteg написал:
ну вот и поведайте нам, в какой именно, чтобы могли его взять для имени листа
Не совсем понял вопрос если честно)
Мне надо что бы имя листа присваивалось из определенной ячейки (к примеру А6) на этом же листе

Цитата
Kuzmich написал:
Кто его туда будет вставлять?Это уникальное значение должно находится на первом листе, чтобы макрос в процессе создания очередного листамог брать это имя.
Так ведь наш макрос и вставляет)

Если я правильно понимаю нужно:
1. перенести данные на новые листы (это благодаря Вам уже сделано)
2. переименовать каждый лист по имени ячейки

То есть макрос переименования листов запускать уже после этапа 1
Или так не получится?
 
Цитата
valex470 написал:
Не совсем понял вопрос если честно)
Ничего, зато ответили в точку :)
Код
Sub StartEnd()
Dim iLastRow As Long
Dim FoundCell As Range
Dim FAdr As String
Dim n As Integer
Dim List1 As Worksheet
Dim FRow As Long
Dim ERow As Long
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   Set List1 = ThisWorkbook.Worksheets("Лист1")
 With Range("A1:A" & iLastRow)
    Set FoundCell = .Find("START", .Cells(.Cells.Count), xlValues, xlWhole, , xlNext)
     If Not FoundCell Is Nothing Then
       FAdr = FoundCell.Address
       n = 1
      Do
       FRow = FoundCell.Row + 1
       ERow = Cells(FRow, "A").End(xlDown).Row - 1
       Set FoundCell = .FindNext(FoundCell)
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = "Набор_" & n
        List1.Range(List1.Cells(FRow, "A"), List1.Cells(ERow, "C")).Copy Range("A1")
        On Error Resume Next
        ActiveSheet.Name=Cells(6,1).Value 'Берём имя листа из ячейки А6
        n = n + 1
        List1.Activate
      Loop While FoundCell.Address <> FAdr
     End If
 End With
End Sub
Изменено: StoTisteg - 04.09.2018 14:33:51
 
Цитата
Мне надо что бы имя листа присваивалось из определенной ячейки (к примеру А6) на этом же листе
Но ведь значение в этой ячейке берется с листа1. У вас там значение 7, для второго блока 16
Какие имена будут иметь создаваемые листы?
 
Цитата
Kuzmich написал:
Но ведь значение в этой ячейке берется с листа1.

Да все верно
Цитата
Kuzmich написал:
У вас там значение 7, для второго блока 16

Я возможно не совсем понятно выразил свою мысль (или Ваш вопрос не совсем понял), но при переносе данных (те, что между маркерами START/END) из листа 1 на новые листы у нас на каждом новом листе в определенной ячейке будет находиться идентификационный номер - то есть номер объекта откуда выгружается соответствующий блок с информацией (из стороннего ПО)

Цитата
Kuzmich написал:
Какие имена будут иметь создаваемые листы?
Если конкретно в моём случае, то это будет цифровое значение


Собственно говоря с учетом правки из сообщения 17 и корректировки в сообщении 15 (стало корректно определять диапазон данных для переноса)
заработало!

Kuzmich, StoTisteg, спасибо Вам большое!

Добавил в конец макроса команду для удаления первого листа
Правда удаляет только по имени листа
Если не затруднит подскажите пожалуйста как можно удалить удалить именно первый лист в книге (без привязки к имени)
Было бы совсем замечательно)

Макрос теперь выглядит так:
Код
Sub Export()
Dim iLastRow As Long
Dim FoundCell As Range
Dim FAdr As String
Dim n As Integer
Dim List1 As Worksheet
Dim FRow As Long
Dim ERow As Long
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   Set List1 = ThisWorkbook.Worksheets("Лист1")
 With Range("A1:A" & iLastRow)
    Set FoundCell = .Find("START", .Cells(.Cells.Count), xlValues, xlWhole, , xlNext)
     If Not FoundCell Is Nothing Then
       FAdr = FoundCell.Address
       n = 1
      Do
       FRow = FoundCell.Row + 1
       ERow = Cells(FRow, "A").End(xlDown).Row - 1
       Set FoundCell = .FindNext(FoundCell)
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = "Набор_" & n
        List1.Rows(FRow & ":" & ERow).Copy Range("A1")
        On Error Resume Next
        ActiveSheet.Name = Cells(5, 1).Value 'Берём имя листа из ячейки А6
        n = n + 1
        List1.Activate
      Loop While FoundCell.Address <> FAdr
     End If
 End With
 Application.DisplayAlerts = False
   Sheets("Лист1").Delete
   Application.DisplayAlerts = True
End Sub
 
Цитата
Cells(5, 1).Value 'Берём имя листа из ячейки А6
Это ячейка А5
 
Да, все верно
Это уже я поправил макрос т.к. сначала не учёл, что поскольку у нас ведь сами маркеры не переносятся и поэтому нужное значение сместилось на ячейку вверх
Комментарий забыл исправить
 
Точно, промахнулся. Причём не я :)
Изменено: StoTisteg - 04.09.2018 15:13:06
 
Так сразу берите название создаваемого листа из ячейки на 6 строк вниз от строки START
List1.Cells(FRow+6,"A")
 
Кстати хорошая идея
Правда я что-то запутался куда её вставить

И что-то мне кажется в этом месте лишние строки есть (повторяется переименование как мне кажется из первоначальной версии макроса), только не знаю какие именно строки удалить/заменить что-бы не сломать макрос
Код
Worksheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = "Набор_" & n
        List1.Rows(FRow & ":" & ERow).Copy Range("A1")
        On Error Resume Next
        ActiveSheet.Name = Cells(5, 1).Value 'Берём имя листа из ячейки А5
        n = n + 1
        List1.Activate
 
Цитата
Правда я что-то запутался куда её вставить
я бы не стал удалять лист1, а сделал бы его скрытным или свехскрытным, все таки это исходные данные
Код
Sub StartEnd()
Dim iLastRow As Long
Dim FoundCell As Range
Dim FAdr As String
Dim List1 As Worksheet
Dim FRow As Long
Dim ERow As Long
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   Set List1 = ThisWorkbook.Worksheets("Лист1")
 With Range("A1:A" & iLastRow)
    Set FoundCell = .Find("START", .Cells(.Cells.Count), xlValues, xlWhole, , xlNext)
     If Not FoundCell Is Nothing Then
       FAdr = FoundCell.Address
      Do
       FRow = FoundCell.Row + 1
       ERow = Cells(FRow, "A").End(xlDown).Row - 1
       Set FoundCell = .FindNext(FoundCell)
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = CStr(List1.Cells(FRow + 5, "A"))
        List1.Rows(FRow & ":" & ERow).Copy Range("A1")
        List1.Activate
      Loop While FoundCell.Address <> FAdr
     End If
 End With
    List1.Visible = xlSheetHidden
End Sub
 
Цитата
Kuzmich написал:
а сделал бы его скрытным или свехскрытным, все таки это исходные данные
Спасибо, но на самом деле в данном случае это излишне - в том ПО откуда осуществляется выгрузка эта информация хранится на защищенных серверах, так что это намного надежнее чем в Экселе)
 
Еще если не затруднит подскажите пожалуйста по 2 обнаруженным нюансам:

1. Если между маркерами END одного блока и START следующего блока имеется пустая строка, то макрос отрабатывает как надо. А вот если START нового блока идет сразу в следующей строке, то макрос переносит на следующий лист данный блок, а также все остальные блоки находящиеся ниже текущего
То есть получается некая информационная "ёлочка" из убывающего количества блоков по листам - на первом создаваемом листе скопированы все блоки, на втором все кроме первого, на втором все кроме 1 и 2 и т.д. То есть лишь на последнем листе находится один (последний из выгрузки) блок

2. если запускаю макрос из текущей книги (то есть создавая его каждый раз), то все нормально, но попробовал сделать его в шаблоне (или как он правильно называется?) "PERSONAL.XLSB" что бы он был доступен в каждой новой книге, то при запуске что-то не срабатывает

Финальный вид макроса
Код
Sub Export()
' Сочетание клавиш: Ctrl+w
Dim iLastRow As Long
Dim FoundCell As Range
Dim FAdr As String
Dim n As Integer
Dim List1 As Worksheet
Dim FRow As Long
Dim ERow As Long
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   Set List1 = ThisWorkbook.Worksheets("Лист1")
 With Range("A1:A" & iLastRow)
    Set FoundCell = .Find("START", .Cells(.Cells.Count), xlValues, xlWhole, , xlNext)
     If Not FoundCell Is Nothing Then
       FAdr = FoundCell.Address
       n = 1
      Do
       FRow = FoundCell.Row + 1
       ERow = Cells(FRow, "A").End(xlDown).Row - 1
       Set FoundCell = .FindNext(FoundCell)
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        List1.Rows(FRow & ":" & ERow).Copy Range("A1")
        On Error Resume Next
        ActiveSheet.Name = Cells(5, 1).Value 'Берём имя листа из ячейки А5
        List1.Activate
      Loop While FoundCell.Address <> FAdr
     End If
 End With
 Application.DisplayAlerts = False
   Sheets("Лист1").Delete
   Application.DisplayAlerts = True
End Sub
 
Для PERSONAL.XLSB ThisWorkbook заменяем на ActiveWorkbook.
 
StoTisteg,Спасибо, сработало!
 
Цитата
StoTisteg написал:
если START нового блока идет сразу в следующей строке, то макрос переносит на следующий лист данный блок, а также все остальные блоки находящиеся ниже текущего
Ну знаете ли, какой пример, такое и решение, Kuzmich всё в точности по Вашему примеру сделал... Мне лениво его код переделывать, я Вам лучше принудительную вставку строк сделаю.
Код
   For iLastRow = ctlls(Rows.Count, 1).End(xlUp).Row To 2 Step -1
      If Cells(iLastRow, 1).Value = "START" And Cells(iLastRow - 1, 1).Value <> "" Then Rows(iLastRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
   Next iLastRow
нужно вставить сразу после
Код
Dim ERow As Long
Изменено: StoTisteg - 05.09.2018 16:19:18
Страницы: 1 2 След.
Наверх