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

Вход

Регистрация

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

 

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

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Размножить строки в таблице по количеству значений 1 столбца (Макросы/Sub)
Размножить строки в таблице по количеству значений 1 столбца
romkinss Дата: Вторник, 27.06.2017, 13:48 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 25
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Уважаемые знатоки. Помогите с макросом.

Дано: таблица, где в первом столбце переменные количеством от 1 до N разделенные запятыми. Макрос должен сработать так. Если в 1 столбце ячейки одно значение (нет запятой) - то строка выдается без изменения. Если в 1 столбце строки несколько значений (разделенных запятыми), то такую строку нужно размножить и в 1 столбце каждой строки подставить одно из значений указанных в оригинальной строке.

В итоге если в 1 столбце строки 5 значений через запятую - то на выходе должно быть пять строк и в 1 столбце каждой строки одно из значений оригинальной.

Файл прилагаю.

Отблагодарю Я.Д.
К сообщению приложен файл: 8447744.xlsx(23Kb)
 
Ответить
СообщениеУважаемые знатоки. Помогите с макросом.

Дано: таблица, где в первом столбце переменные количеством от 1 до N разделенные запятыми. Макрос должен сработать так. Если в 1 столбце ячейки одно значение (нет запятой) - то строка выдается без изменения. Если в 1 столбце строки несколько значений (разделенных запятыми), то такую строку нужно размножить и в 1 столбце каждой строки подставить одно из значений указанных в оригинальной строке.

В итоге если в 1 столбце строки 5 значений через запятую - то на выходе должно быть пять строк и в 1 столбце каждой строки одно из значений оригинальной.

Файл прилагаю.

Отблагодарю Я.Д.

Автор - romkinss
Дата добавления - 27.06.2017 в 13:48
Udik Дата: Вторник, 27.06.2017, 14:04 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1587
Репутация: 191 ±
Замечаний: 0% ±

Excel 2016 х 64
тогда надо во фриланс перенести. И я таки готов взяться. :)


вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com
 
Ответить
Сообщениетогда надо во фриланс перенести. И я таки готов взяться. :)

Автор - Udik
Дата добавления - 27.06.2017 в 14:04
Manyasha Дата: Вторник, 27.06.2017, 14:23 | Сообщение № 3
Группа: Модераторы
Ранг: Старожил
Сообщений: 1958
Репутация: 815 ±
Замечаний: 0% ±

Excel 2010, 2016
romkinss, переношу в платную ветку?


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщениеromkinss, переношу в платную ветку?

Автор - Manyasha
Дата добавления - 27.06.2017 в 14:23
_Boroda_ Дата: Вторник, 27.06.2017, 14:33 | Сообщение № 4
Группа: Модераторы
Ранг: Местный житель
Сообщений: 11315
Репутация: 4675 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Обычно, когда пишут
Отблагодарю Я.Д.
, то это не подразумевает действительно "Работы за плату". Чаще всего благодарность носит чисто символический характер. Потому-то в подобных случаях я даже не спрашиваю про перенос в ветку Фриланс.
Но в данном случае, раз уж появились такие посты, то нужно указание автора. И, если во Фриланс, то переход хода к Udik
[p.s.]Правда я, не посмотрев, что в теме уже есть ответы, уже написал макрос, ну да и ладно


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеОбычно, когда пишут
Отблагодарю Я.Д.
, то это не подразумевает действительно "Работы за плату". Чаще всего благодарность носит чисто символический характер. Потому-то в подобных случаях я даже не спрашиваю про перенос в ветку Фриланс.
Но в данном случае, раз уж появились такие посты, то нужно указание автора. И, если во Фриланс, то переход хода к Udik
[p.s.]Правда я, не посмотрев, что в теме уже есть ответы, уже написал макрос, ну да и ладно

Автор - _Boroda_
Дата добавления - 27.06.2017 в 14:33
Kuzmich Дата: Вторник, 27.06.2017, 15:05 | Сообщение № 5
Группа: Проверенные
Ранг: Обитатель
Сообщений: 299
Репутация: 56 ±
Замечаний: 0% ±

Excel 2003
Аналогичная тема, где есть решение от Nilem
http://www.excelworld.ru/forum/10-34266-1
 
Ответить
СообщениеАналогичная тема, где есть решение от Nilem
http://www.excelworld.ru/forum/10-34266-1

Автор - Kuzmich
Дата добавления - 27.06.2017 в 15:05
romkinss Дата: Вторник, 27.06.2017, 15:14 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 25
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Уважаемые, никуда переносить не нужно. Это действительно символическая благодарность, которая несет исключительно кармическую подоплеку.
 
Ответить
СообщениеУважаемые, никуда переносить не нужно. Это действительно символическая благодарность, которая несет исключительно кармическую подоплеку.

Автор - romkinss
Дата добавления - 27.06.2017 в 15:14
_Boroda_ Дата: Вторник, 27.06.2017, 15:20 | Сообщение № 7
Группа: Модераторы
Ранг: Местный житель
Сообщений: 11315
Репутация: 4675 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Тада вот
[vba]
Код
Sub tt()
    r0_ = 5
    r1_ = Range("A" & Rows.Count).End(3).Row
    If r1_ < r0_ Then Exit Sub
    c1_ = ActiveCell.SpecialCells(xlLastCell).Column
    arz = Range("A" & r0_).Resize(r1_ - r0_ + 1, c1_)
    Application.ScreenUpdating = 0
    Application.Calculation = xlCalculationManual
    For i = UBound(arz) To 1 Step -1
        If InStr(arz(i, 1), ",") Then
            armas = Split(arz(i, 1), ",")
            Range("A" & r0_ + i).Resize(UBound(armas)).EntireRow.Insert
            Range("A" & r0_ + i).Resize(UBound(armas), c1_) = WorksheetFunction.Index(arz, i, 0)
            Range("A" & r0_ + i - 1).Resize(UBound(armas) + 1, 1) = Application.Transpose(armas)
        End If
    Next i
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = 1
End Sub
[/vba]
У Николая по ссылке лучше. У меня много обращений к листу, а у него два. На больших объемах это может сказаться на скорости
К сообщению приложен файл: 8447744_1.xlsm(19Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеТада вот
[vba]
Код
Sub tt()
    r0_ = 5
    r1_ = Range("A" & Rows.Count).End(3).Row
    If r1_ < r0_ Then Exit Sub
    c1_ = ActiveCell.SpecialCells(xlLastCell).Column
    arz = Range("A" & r0_).Resize(r1_ - r0_ + 1, c1_)
    Application.ScreenUpdating = 0
    Application.Calculation = xlCalculationManual
    For i = UBound(arz) To 1 Step -1
        If InStr(arz(i, 1), ",") Then
            armas = Split(arz(i, 1), ",")
            Range("A" & r0_ + i).Resize(UBound(armas)).EntireRow.Insert
            Range("A" & r0_ + i).Resize(UBound(armas), c1_) = WorksheetFunction.Index(arz, i, 0)
            Range("A" & r0_ + i - 1).Resize(UBound(armas) + 1, 1) = Application.Transpose(armas)
        End If
    Next i
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = 1
End Sub
[/vba]
У Николая по ссылке лучше. У меня много обращений к листу, а у него два. На больших объемах это может сказаться на скорости

Автор - _Boroda_
Дата добавления - 27.06.2017 в 15:20
romkinss Дата: Вторник, 27.06.2017, 15:27 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 25
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Спасибо за помощь, работает так как нужно!


Сообщение отредактировал romkinss - Вторник, 27.06.2017, 15:29
 
Ответить
СообщениеСпасибо за помощь, работает так как нужно!

Автор - romkinss
Дата добавления - 27.06.2017 в 15:27
romkinss Дата: Вторник, 27.06.2017, 16:44 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 25
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
В процессе обкатки выявился баг. Если "множить" 20, 30 строк (а в итоге мне нужно обработать 5000 строк) - то макрос затирает оригинальную таблицу. Подскажите, как сделать, чтобы макрос результат выводил на отдельном листе книги?


Сообщение отредактировал romkinss - Вторник, 27.06.2017, 17:04
 
Ответить
СообщениеВ процессе обкатки выявился баг. Если "множить" 20, 30 строк (а в итоге мне нужно обработать 5000 строк) - то макрос затирает оригинальную таблицу. Подскажите, как сделать, чтобы макрос результат выводил на отдельном листе книги?

Автор - romkinss
Дата добавления - 27.06.2017 в 16:44
_Boroda_ Дата: Вторник, 27.06.2017, 17:59 | Сообщение № 10
Группа: Модераторы
Ранг: Местный житель
Сообщений: 11315
Репутация: 4675 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Там, как оказалось, под Index не съедается текстовая строка с количеством символов, большим 256.
Попробуйте так
[vba]
Код
Sub tt()
    Dim arz()
    r0_ = 5
    r1_ = Range("A" & Rows.Count).End(3).Row
    If r1_ < r0_ Then Exit Sub
    c1_ = ActiveCell.SpecialCells(xlLastCell).Column
    ReDim arz(r1_ - r0_, c1_ - 1)
    arz = Range("A" & r0_).Resize(r1_ - r0_ + 1)
    arz1 = Range("B" & r0_).Resize(r1_ - r0_ + 1, c1_)
    Application.ScreenUpdating = 0
    Application.Calculation = xlCalculationManual
    For i = UBound(arz) To 1 Step -1
        If InStr(arz(i, 1), ",") Then
            armas = Split(arz(i, 1), ",")
            Range("A" & r0_ + i).Resize(UBound(armas)).EntireRow.Insert
            fff = WorksheetFunction.Index(arz1, 0, i)
            Range("B" & r0_ + i).Resize(UBound(armas), c1_ - 1) = WorksheetFunction.Index(arz1, i, 0)
            Range("A" & r0_ + i - 1).Resize(UBound(armas) + 1) = Application.Transpose(armas)
        End If
    Next i
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = 1
End Sub
[/vba]
А вообще-то лучше используйте макрос по ссылке


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеТам, как оказалось, под Index не съедается текстовая строка с количеством символов, большим 256.
Попробуйте так
[vba]
Код
Sub tt()
    Dim arz()
    r0_ = 5
    r1_ = Range("A" & Rows.Count).End(3).Row
    If r1_ < r0_ Then Exit Sub
    c1_ = ActiveCell.SpecialCells(xlLastCell).Column
    ReDim arz(r1_ - r0_, c1_ - 1)
    arz = Range("A" & r0_).Resize(r1_ - r0_ + 1)
    arz1 = Range("B" & r0_).Resize(r1_ - r0_ + 1, c1_)
    Application.ScreenUpdating = 0
    Application.Calculation = xlCalculationManual
    For i = UBound(arz) To 1 Step -1
        If InStr(arz(i, 1), ",") Then
            armas = Split(arz(i, 1), ",")
            Range("A" & r0_ + i).Resize(UBound(armas)).EntireRow.Insert
            fff = WorksheetFunction.Index(arz1, 0, i)
            Range("B" & r0_ + i).Resize(UBound(armas), c1_ - 1) = WorksheetFunction.Index(arz1, i, 0)
            Range("A" & r0_ + i - 1).Resize(UBound(armas) + 1) = Application.Transpose(armas)
        End If
    Next i
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = 1
End Sub
[/vba]
А вообще-то лучше используйте макрос по ссылке

Автор - _Boroda_
Дата добавления - 27.06.2017 в 17:59
Udik Дата: Вторник, 27.06.2017, 18:22 | Сообщение № 11
Группа: Друзья
Ранг: Старожил
Сообщений: 1587
Репутация: 191 ±
Замечаний: 0% ±

Excel 2016 х 64
мой вариант
[vba]
Код

Public Sub insRow()
Dim i As Long, rowLast&, j&, k&
Dim rng1 As Range
Dim clnLast&, rowStart&
Dim arrStr

    With ThisWorkbook.ActiveSheet
        
        rowStart = 5
        rowLast = .Cells(Rows.Count, 1).End(xlUp).Row
        clnLast = .Cells(rowStart, Columns.Count).End(xlToLeft).Column
        For i = rowLast To rowStart Step -1
          arrStr = Split(.Cells(i, 1).Value, ",")
          If UBound(arrStr) > 0 Then
              Set rng1 = .Range(.Cells(i, 2), .Cells(i, clnLast))
              
              For j = UBound(arrStr) To 1 Step -1
                  k = i + 1
                  .Rows(k & ":" & k).Insert
                  rng1.Copy Destination:=.Cells(k, 2)
                  .Cells(k, 1).Value = arrStr(j)
              Next j
              .Cells(i, 1).Value = arrStr(0)
        
          End If
        
        Next i
    End With
End Sub
[/vba]


вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com
 
Ответить
Сообщениемой вариант
[vba]
Код

Public Sub insRow()
Dim i As Long, rowLast&, j&, k&
Dim rng1 As Range
Dim clnLast&, rowStart&
Dim arrStr

    With ThisWorkbook.ActiveSheet
        
        rowStart = 5
        rowLast = .Cells(Rows.Count, 1).End(xlUp).Row
        clnLast = .Cells(rowStart, Columns.Count).End(xlToLeft).Column
        For i = rowLast To rowStart Step -1
          arrStr = Split(.Cells(i, 1).Value, ",")
          If UBound(arrStr) > 0 Then
              Set rng1 = .Range(.Cells(i, 2), .Cells(i, clnLast))
              
              For j = UBound(arrStr) To 1 Step -1
                  k = i + 1
                  .Rows(k & ":" & k).Insert
                  rng1.Copy Destination:=.Cells(k, 2)
                  .Cells(k, 1).Value = arrStr(j)
              Next j
              .Cells(i, 1).Value = arrStr(0)
        
          End If
        
        Next i
    End With
End Sub
[/vba]

Автор - Udik
Дата добавления - 27.06.2017 в 18:22
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Размножить строки в таблице по количеству значений 1 столбца (Макросы/Sub)
Страница 1 из 11
Поиск:

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