Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Разделение столба между контрольными словами по листам - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Разделение столба между контрольными словами по листам (Макросы/Sub)
Разделение столба между контрольными словами по листам
Driven2002 Дата: Среда, 16.10.2019, 23:14 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Добрый день!

В Готовых решениях нашёл тему по Разделению таблицы по листам по критерию www.excelworld.ru
подскажите пожалуйста как адаптировать код макроса (Сам не очень селен в VBA) для разделения одного столба по листам по заданным критериям

[vba]
Код


Sub DivEtImp(Optional ByVal Col As Long = 1, Optional ByVal Del As Boolean = True)

   Dim i As Long, cl As Long, rw As Long
   Dim Dic As Object
   Dim ShNam As String, Bads() As String
   Dim Bad As Variant
    
   Application.ScreenUpdating = False
   Set Dic = CreateObject("Scripting.Dictionary")
   With Worksheets(1)
      cl = .Cells(1, Columns.Count).End(xlToLeft).Column
      rw = .Cells(Rows.Count, Col).End(xlUp).Row
      For i = 2 To .Cells(Rows.Count, Col).End(xlUp).Row
         On Error Resume Next
         Dic.Add Key:=Trim(.Cells(i, Col).Value), Item:=""
      Next i
   End With
   Application.ScreenUpdating = False
   With Dic
      For i = 0 To .Count - 1
         Worksheets(1).Copy after:=Worksheets(Sheets.Count)
         Bads = Array(":", "\", "/", "[", "]", "?", "*")
         ShNam = .Keys()(i)
         For Each Bad In Bads
            ShNam = Replace(ShNam, Bad, " ", 1, -1, vbTextCompare)
         Next Bad
         ActiveSheet.Name = Left(ShNam, 31)
         Cells(1, Col).Copy Destination:=Cells(1, cl + 2)
         Cells(2, cl + 2).Value = .Keys()(i)
         Range(Cells(1, 1), Cells(rw, cl)).AdvancedFilter Action:=xlFilterCopy, criteriarange:=Range(Cells(1, cl + 2), Cells(2, cl + 2)), copytorange:=Cells(1, cl + 4)
         Range(Columns(1), Columns(cl + 3)).Delete
         If Del Then Columns(Col).Delete
         Range(Columns(1), Columns(IIf(Del, cl - 1, cl))).EntireColumn.AutoFit
      Next i
   End With
   Application.ScreenUpdating = True
End Sub

[/vba].
имеется таблица с размещенными сведениями в одном столбе

критерий-1
текст
текст
текст

критерий-2
текст
текст
текст

критерий-2
текст
текст
текст

макрос должен создать лист с названием "критерий-1" и выбрать туда в первый столбец все строки до критерия-2
дальше создать лист с названием "критерий-2" и выбрать туда в первый столбец все строки до критерия-3 и т.д.
а. так же сравнивать название критериев с названием уже существующих листов, в случаи их совпадения добавлять туда новые данные

файл для примера с исходным макросом лист1, на листе 2 импровизированная таблица которую не обходимо разделить с конечным вариантом в виде талицы.
К сообщению приложен файл: 6164028.xlsm (24.8 Kb)
 
Ответить
СообщениеДобрый день!

В Готовых решениях нашёл тему по Разделению таблицы по листам по критерию www.excelworld.ru
подскажите пожалуйста как адаптировать код макроса (Сам не очень селен в VBA) для разделения одного столба по листам по заданным критериям

[vba]
Код


Sub DivEtImp(Optional ByVal Col As Long = 1, Optional ByVal Del As Boolean = True)

   Dim i As Long, cl As Long, rw As Long
   Dim Dic As Object
   Dim ShNam As String, Bads() As String
   Dim Bad As Variant
    
   Application.ScreenUpdating = False
   Set Dic = CreateObject("Scripting.Dictionary")
   With Worksheets(1)
      cl = .Cells(1, Columns.Count).End(xlToLeft).Column
      rw = .Cells(Rows.Count, Col).End(xlUp).Row
      For i = 2 To .Cells(Rows.Count, Col).End(xlUp).Row
         On Error Resume Next
         Dic.Add Key:=Trim(.Cells(i, Col).Value), Item:=""
      Next i
   End With
   Application.ScreenUpdating = False
   With Dic
      For i = 0 To .Count - 1
         Worksheets(1).Copy after:=Worksheets(Sheets.Count)
         Bads = Array(":", "\", "/", "[", "]", "?", "*")
         ShNam = .Keys()(i)
         For Each Bad In Bads
            ShNam = Replace(ShNam, Bad, " ", 1, -1, vbTextCompare)
         Next Bad
         ActiveSheet.Name = Left(ShNam, 31)
         Cells(1, Col).Copy Destination:=Cells(1, cl + 2)
         Cells(2, cl + 2).Value = .Keys()(i)
         Range(Cells(1, 1), Cells(rw, cl)).AdvancedFilter Action:=xlFilterCopy, criteriarange:=Range(Cells(1, cl + 2), Cells(2, cl + 2)), copytorange:=Cells(1, cl + 4)
         Range(Columns(1), Columns(cl + 3)).Delete
         If Del Then Columns(Col).Delete
         Range(Columns(1), Columns(IIf(Del, cl - 1, cl))).EntireColumn.AutoFit
      Next i
   End With
   Application.ScreenUpdating = True
End Sub

[/vba].
имеется таблица с размещенными сведениями в одном столбе

критерий-1
текст
текст
текст

критерий-2
текст
текст
текст

критерий-2
текст
текст
текст

макрос должен создать лист с названием "критерий-1" и выбрать туда в первый столбец все строки до критерия-2
дальше создать лист с названием "критерий-2" и выбрать туда в первый столбец все строки до критерия-3 и т.д.
а. так же сравнивать название критериев с названием уже существующих листов, в случаи их совпадения добавлять туда новые данные

файл для примера с исходным макросом лист1, на листе 2 импровизированная таблица которую не обходимо разделить с конечным вариантом в виде талицы.

Автор - Driven2002
Дата добавления - 16.10.2019 в 23:14
Pelena Дата: Четверг, 17.10.2019, 19:26 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 19158
Репутация: 4411 ±
Замечаний: ±

Excel 365 & Mac Excel
Названия листов только по цвету идентифицируются?


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеНазвания листов только по цвету идентифицируются?

Автор - Pelena
Дата добавления - 17.10.2019 в 19:26
Driven2002 Дата: Пятница, 18.10.2019, 17:32 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Цвет не какого отношения к делению на листы не имеет.
В лист 1 размещается в один столбик текст (столб А), который вставляется из документа word.
В строках этого столба содержаться контрольные слова по которым как пирог должен быть разрезан на куски столбец, а эти куски размещены по листам с названием контрольного слова.В приложеном мной файле роль контрольных слов выполняют название фруктов. А роль текста в столбе выполняет название сортов фруктов. Как и в примере в тесте содержаться в разнабой
Пустые сроки.
 
Ответить
СообщениеЦвет не какого отношения к делению на листы не имеет.
В лист 1 размещается в один столбик текст (столб А), который вставляется из документа word.
В строках этого столба содержаться контрольные слова по которым как пирог должен быть разрезан на куски столбец, а эти куски размещены по листам с названием контрольного слова.В приложеном мной файле роль контрольных слов выполняют название фруктов. А роль текста в столбе выполняет название сортов фруктов. Как и в примере в тесте содержаться в разнабой
Пустые сроки.

Автор - Driven2002
Дата добавления - 18.10.2019 в 17:32
Driven2002 Дата: Суббота, 19.10.2019, 21:38 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
можно эти куски выводить не в отельные листы, в другие столбы начиная с третьего этого же листа
 
Ответить
Сообщениеможно эти куски выводить не в отельные листы, в другие столбы начиная с третьего этого же листа

Автор - Driven2002
Дата добавления - 19.10.2019 в 21:38
Driven2002 Дата: Понедельник, 21.10.2019, 21:53 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
НАШЕЛ Я РЕШЕНИЕ ЭТОГО ВОПРОСА

[vba]
Код
Sheets("ЛИСТ1").Range(Range("a:a").Find("КРИТЕРИЙ-1", , xlValues, xlWhole).Address, Range("a:a").Find("КРИТЕРИЙ-2", , xlValues, xlWhole).Address).Copy Sheets("ЛИСТ1").Range("I:I")
[/vba]

Подскажите как сделать так чтобы при работе кода в случае нахождения второго аналогичного повторения текст добовлялся ниже уже скапированых данных?
 
Ответить
СообщениеНАШЕЛ Я РЕШЕНИЕ ЭТОГО ВОПРОСА

[vba]
Код
Sheets("ЛИСТ1").Range(Range("a:a").Find("КРИТЕРИЙ-1", , xlValues, xlWhole).Address, Range("a:a").Find("КРИТЕРИЙ-2", , xlValues, xlWhole).Address).Copy Sheets("ЛИСТ1").Range("I:I")
[/vba]

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

Автор - Driven2002
Дата добавления - 21.10.2019 в 21:53
Driven2002 Дата: Суббота, 26.10.2019, 15:19 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 37
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Добрый день! подскажите, не могу понять почему почему этот код то копирует выбранный диапазон в заданный столбец 1 раз, то копирует один и тот же диапазон несколько раз. как сделать так что все таки копировался один раз?

[vba]
Код
Range(Range("a1:a2000").Find("Раздел16", , xlValues, xlWhole).Address, Range("a1:a2000").Find("Раздел17", , xlValues, xlWhole).Address).Copy Range("S9:S1000")
[/vba]
 
Ответить
СообщениеДобрый день! подскажите, не могу понять почему почему этот код то копирует выбранный диапазон в заданный столбец 1 раз, то копирует один и тот же диапазон несколько раз. как сделать так что все таки копировался один раз?

[vba]
Код
Range(Range("a1:a2000").Find("Раздел16", , xlValues, xlWhole).Address, Range("a1:a2000").Find("Раздел17", , xlValues, xlWhole).Address).Copy Range("S9:S1000")
[/vba]

Автор - Driven2002
Дата добавления - 26.10.2019 в 15:19
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Разделение столба между контрольными словами по листам (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!