Страницы: 1
RSS
Разделить данные Листа на несколько отдельных листов
 
Добрый вечер уважаемые знатоки.
Есть исходный файл с заказами от клиента. Нужно разделить эти данные на отдельные листы, чтобы на каждом листе был отдельный заказ. В исходном файле может быть разное количество заказов с разным количеством строк, но вид всегда одинаковый. Пример того, что должно получаться прикладываю. Пробовала ВПР. Не получилось от слова совсем. В ручную делать - это просто беда. Может кто поможет формулой или макросом?
 
Удалось собрать все данные в одну общую таблицу.
Теперь нужно понять, как сделать так, чтобы кусок таблицы от ячейки с символом № и до следующей ячейки с символом № перенесся на отдельный лист (имя листа не важно) и так до конца таблицы. В макросах ни бум-бум, формулы не помогают
Пример прикрепляю
 
 
Цитата
Пример того, что должно получаться прикладываю
Я так понимаю, что у вас есть файл с одним листом Лист1 и надо сформировать n-ое количество листов под именами номера заказа.
Имена заказов у вас уникальные?
Смущает, что вы
Цитата
В макросах ни бум-бум
как будете разбираться?
 
Да изначально файл один, важно не присвоить листам имя заказа, это не принципиально. Главное разделить заказы по разным листам.
Цитата
Смущает, что вы
Цитата
В макросах ни бум-бум
как будете разбираться?
я представляю в общих чертах что это и как оно устроено, но написать сама не могу. Через запись макроса не считается)))
 
Kuzmich, если побаловаться с фильтрами то можно привести Исходный файл к варианту Исходный файл 2. Я даже примерно понимаю что должен делать excel, но как ему объяснить что мне нужно я не знаю
 
В исходный файл с одним листом Лист1 вставьте в стандартный модуль код.
Код
Sub Tablica()
Dim NewSheet As Worksheet
Dim iLR As Long
Dim iRow_Begin As Long
Dim iNomer As String
Dim FoundNomerSwerki As Range
Dim FAdr As String
Application.ScreenUpdating = False
    Set FoundNomerSwerki = Columns("C:D").Find("Номер сверки заказа:", , xlValues, xlWhole)
      FAdr = FoundNomerSwerki.Address
    Do
      iRow_Begin = FoundNomerSwerki.Row                     'начало очередного диапазона по номеру сверки
      iNomer = FoundNomerSwerki.Offset(, 1)                 'номер сверки
      iLR = FoundNomerSwerki.Offset(5).End(xlDown).Row      'конец  очередного диапазона
      
      'здесь копируем диапазон от iRow_Begin до iLR и вставляем в лист с именем iNomer
      'если такого листа нет, то добавляем лист
        If Not SheetExist(iNomer) Then                      'функция проверки наличия листа в файле
          Set NewSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
          NewSheet.Name = iNomer
          With Worksheets("Лист1")
            .Range(.Cells(iRow_Begin, "C"), .Cells(iLR, "Z")).Copy Range("A1")
            .Activate
          End With
        End If
      Set FoundNomerSwerki = Columns("C:D").FindNext(FoundNomerSwerki)
    Loop While FoundNomerSwerki.Address <> FAdr
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 запустите макрос Tablica()
 
Kuzmich, Спасибо огромное!!!! У меня почему-то русские буквы вопросами стали. С этим потом разберемся)) ручками поправила. Все работает как часы. Ещё раз огромное спасибо
 
Екатерина Новикова, копировать код макроса нужно при установленной русской раскладке клавиатуры Windows, чтобы русские буквы не становились вопросами.
Т.е. сперва смените раскладку клавиатуры на РУС, потом скопируйте код от Kuzmich и вставьте его себе в свой файл и всё будет ОК
Изменено: New - 10.06.2022 00:21:20
 
New,  спасибо за подсказку. Буду знать в следующий раз. С этим уже разобралась)) Когда же я так научусь....
 
Kuzmich,ну помогите мне ещё раз, пожалуйста
Попыталась с помощью макроса вставлять в ячейку комментарий.

Sub КомментарийДНС()
'
' КомментарийДНС Макрос
'

'
   Range("G3").Select
   ActiveCell.FormulaR1C1 = _
       "город, дата, Отправитель: ООО Офисмаг/EY0481, тип, склад29"
   Range("H3").Select
   ActiveCell.FormulaR1C1 = "=TODAY()+4"
   Range("I3").Select
   ActiveCell.FormulaR1C1 = _
       "=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(RC[-2],""город"",R[3]C[13]),""дата"",RC[-1]),""тип"",R[3]C[11])"
   Range("I4:I5").Select
   ActiveWindow.ScrollColumn = 7
   ActiveWindow.ScrollColumn = 6
   ActiveWindow.ScrollColumn = 5
   ActiveWindow.ScrollColumn = 4
   ActiveWindow.ScrollColumn = 3
   Range("I3").Select
   Selection.Copy
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
End Sub

Не знаю как красиво прилепить макрос в сообщение((
В целом он работает, но в формуле =SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(RC[-2],""город"",R[3]C[13]),""дата"",RC[-1]),""тип"",R[3]C[11]), вместо даты появляется 44729. Это возможно как-то исправить?
 
Екатерина Новикова,  посмотрите, как оформлен код в #6. Вот и Вы так оформляйте: для этого используйте кнопку <...>
И какое отношение вставка комментария имеет к заявленной теме?
 
Юрий М, Создала новую тему. Макрос вставила корректно. Спасибо
Страницы: 1
Наверх