Страницы: 1
RSS
разделить таблицу на листы
 
Существует таблица в первом листе (1st sheet). Эту таблицу надо разделить на страницы по регионам, например Москва в одном, Питер в другом листе и т.д. У меня на примере есть макрос (спасибо Kuzmich - у) но надо делать изменения. (дает дебуг)И  макросе можно так сделать чтобы там строки или столбцы тоже я сам определил. Потому что может быть этот макрос ещё понадобится мне в других книгах тоже. Заранее спасибо
Код
Sub iTown()
Dim i As Long
Dim n As Integer
Dim Criterij As String
Dim iName As String
Dim Sht As Worksheet
Application.ScreenUpdating = False
  Set Sht = ThisWorkbook.Worksheets("MH-2019")
        Columns("E").ClearContents
    Range("C3:C" & Cells(Rows.Count, "C").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy _
                                  , CopyToRange:=Range("E3"), Unique:=True
        n = Cells(Rows.Count, "E").End(xlUp).Row
    For i = 4 To n          'цикл по уникальным значениям
        Criterij = Sht.Cells(i, "E")
        iName = Criterij    'имя нового листа
       Sht.Range("A3:C" & Cells(Rows.Count, "C").End(xlUp).Row).AutoFilter 3, Criterij
        Sht.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
        With Worksheets.Add(After:=Worksheets(Worksheets.Count))  'добавляет новый лист в конец
          .Range("A1:C1").PasteSpecial xlPasteColumnWidths
          .Range("A1:C1").PasteSpecial xlPasteFormats
          .Range("A1:C1").PasteSpecial xlPasteValues
          Sht.AutoFilter.Range.AutoFilter
          .Name = iName
          .Range("A1").Select
        End With
    Next
Application.ScreenUpdating = True
End Sub

Изменено: mk92 - 21.09.2019 22:26:09
 
Посмотрите https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=90550
 
Там написано макрос. Но не работает,даёт debug :sceptic:  
 
У вас язык азербайджанский я так понял. В ходе написания макроса надо быть внимательным. Некоторые символы могут не поддерживаться.
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок.
А в том, чтобы писать программы, работающие при любом количестве ошибок.
 
Да,азербайджанский язык. Я хотел исправить makros но не получился
 
Цитата
хотел исправить makros но не получился
Код
Sub iTown()
Dim i As Long
Dim n As Integer
Dim Criterij As String
Dim iName As String
Dim Sht As Worksheet
Application.ScreenUpdating = False
  Set Sht = ThisWorkbook.Worksheets("MH-2019")
        Columns("E").ClearContents
     'отбор уникальных значений столбца C в столбец E
    Range("C3:C" & Cells(Rows.Count, "C").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy _
                                  , CopyToRange:=Range("E3"), Unique:=True
     'количество уникальных значений городов
        n = Cells(Rows.Count, "E").End(xlUp).Row
    For i = 4 To n          'цикл по уникальным значениям
        Criterij = Sht.Cells(i, "E")
        iName = Criterij    'имя нового листа
     'ставим автофильтр по столбцу C
       Sht.Range("A3:C" & Cells(Rows.Count, "C").End(xlUp).Row).AutoFilter 3, Criterij
     'копируем видимые строки в новый лист
        Sht.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
        With Worksheets.Add(After:=Worksheets(Worksheets.Count))  'добавляет новый лист в конец
          .Range("A1:C1").PasteSpecial xlPasteColumnWidths
          .Range("A1:C1").PasteSpecial xlPasteFormats
          .Range("A1:C1").PasteSpecial xlPasteValues
          Sht.AutoFilter.Range.AutoFilter
          .Name = iName
          .Range("A1").Select
        End With
    Next
Application.ScreenUpdating = True
End Sub
 
Спасибо, очень благодарен Kuzmich.
Изменено: mk92 - 20.09.2019 10:02:26
 
debug, debug , debug :evil:  :(  
 
Вставьте макрос из сообщения #6 в стандартный модуль и запустите iTown
 
Сейчас дает такое ошибку :evil:
 
Во всех строках, выделенных красным, удалите все, что левее видимого текста.
Суслика видишь? А он есть!
 
mk92, У вас при копировании кода с форума и вставке его в модуль произошли какие-то ошибки.
Копировать и вставлять нужно при русской раскладке клавиатуры (не уверен, что она у вас есть)
Посмотрите в приложенном архиве пример макроса. Я оставил только три города, остальную таблицу добавьте сами.
Удачи!
 
Сейчас это тоже попробую. ещё раз спасибо тебе Kuzmich.
Страницы: 1
Наверх