Размножить строки в таблице по количеству значений 1 столбца
romkinss
Дата: Вторник, 27.06.2017, 13:48 |
Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 31
Репутация:
0
±
Замечаний:
0% ±
Excel 2013
Уважаемые знатоки. Помогите с макросом. Дано: таблица, где в первом столбце переменные количеством от 1 до N разделенные запятыми. Макрос должен сработать так. Если в 1 столбце ячейки одно значение (нет запятой) - то строка выдается без изменения. Если в 1 столбце строки несколько значений (разделенных запятыми), то такую строку нужно размножить и в 1 столбце каждой строки подставить одно из значений указанных в оригинальной строке. В итоге если в 1 столбце строки 5 значений через запятую - то на выходе должно быть пять строк и в 1 столбце каждой строки одно из значений оригинальной. Файл прилагаю. Отблагодарю Я.Д.
Уважаемые знатоки. Помогите с макросом. Дано: таблица, где в первом столбце переменные количеством от 1 до N разделенные запятыми. Макрос должен сработать так. Если в 1 столбце ячейки одно значение (нет запятой) - то строка выдается без изменения. Если в 1 столбце строки несколько значений (разделенных запятыми), то такую строку нужно размножить и в 1 столбце каждой строки подставить одно из значений указанных в оригинальной строке. В итоге если в 1 столбце строки 5 значений через запятую - то на выходе должно быть пять строк и в 1 столбце каждой строки одно из значений оригинальной. Файл прилагаю. Отблагодарю Я.Д. romkinss
Ответить
Сообщение Уважаемые знатоки. Помогите с макросом. Дано: таблица, где в первом столбце переменные количеством от 1 до N разделенные запятыми. Макрос должен сработать так. Если в 1 столбце ячейки одно значение (нет запятой) - то строка выдается без изменения. Если в 1 столбце строки несколько значений (разделенных запятыми), то такую строку нужно размножить и в 1 столбце каждой строки подставить одно из значений указанных в оригинальной строке. В итоге если в 1 столбце строки 5 значений через запятую - то на выходе должно быть пять строк и в 1 столбце каждой строки одно из значений оригинальной. Файл прилагаю. Отблагодарю Я.Д. Автор - romkinss Дата добавления - 27.06.2017 в 13:48
Udik
Дата: Вторник, 27.06.2017, 14:04 |
Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1588
Репутация:
192
±
Замечаний:
0% ±
Excel 2016 х 64
тогда надо во фриланс перенести. И я таки готов взяться.
тогда надо во фриланс перенести. И я таки готов взяться. Udik
вот вам барабан яд 41001231307558 wm R419131876897 udik1968@gmail.com
Ответить
Сообщение тогда надо во фриланс перенести. И я таки готов взяться. Автор - Udik Дата добавления - 27.06.2017 в 14:04
Manyasha
Дата: Вторник, 27.06.2017, 14:23 |
Сообщение № 3
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация:
898
±
Замечаний:
0% ±
Excel 2010, 2016
romkinss , переношу в платную ветку?
romkinss , переношу в платную ветку?Manyasha
ЯД: 410013299366744 WM: R193491431804
Ответить
Сообщение romkinss , переношу в платную ветку?Автор - Manyasha Дата добавления - 27.06.2017 в 14:23
_Boroda_
Дата: Вторник, 27.06.2017, 14:33 |
Сообщение № 4
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16675
Репутация:
6481
±
Замечаний:
0% ±
2003; 2007; 2010; 2013 RUS
Обычно, когда пишут, то это не подразумевает действительно "Работы за плату". Чаще всего благодарность носит чисто символический характер. Потому-то в подобных случаях я даже не спрашиваю про перенос в ветку Фриланс. Но в данном случае, раз уж появились такие посты, то нужно указание автора. И, если во Фриланс, то переход хода к Udik [p.s.]Правда я, не посмотрев, что в теме уже есть ответы, уже написал макрос, ну да и ладно
Обычно, когда пишут, то это не подразумевает действительно "Работы за плату". Чаще всего благодарность носит чисто символический характер. Потому-то в подобных случаях я даже не спрашиваю про перенос в ветку Фриланс. Но в данном случае, раз уж появились такие посты, то нужно указание автора. И, если во Фриланс, то переход хода к Udik [p.s.]Правда я, не посмотрев, что в теме уже есть ответы, уже написал макрос, ну да и ладно _Boroda_
Скажи мне, кудесник, любимец ба’гов... Платная помощь: 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
Группа: Проверенные
Ранг: Ветеран
Сообщений: 711
Репутация:
156
±
Замечаний:
0% ±
Excel 2003
Ответить
romkinss
Дата: Вторник, 27.06.2017, 15:14 |
Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 31
Репутация:
0
±
Замечаний:
0% ±
Excel 2013
Уважаемые, никуда переносить не нужно. Это действительно символическая благодарность, которая несет исключительно кармическую подоплеку.
Уважаемые, никуда переносить не нужно. Это действительно символическая благодарность, которая несет исключительно кармическую подоплеку. romkinss
Ответить
Сообщение Уважаемые, никуда переносить не нужно. Это действительно символическая благодарность, которая несет исключительно кармическую подоплеку. Автор - romkinss Дата добавления - 27.06.2017 в 15:14
_Boroda_
Дата: Вторник, 27.06.2017, 15:20 |
Сообщение № 7
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16675
Репутация:
6481
±
Замечаний:
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] У Николая по ссылке лучше. У меня много обращений к листу, а у него два. На больших объемах это может сказаться на скорости
Тада вот [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_
Скажи мне, кудесник, любимец ба’гов... Платная помощь: 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
Группа: Пользователи
Ранг: Новичок
Сообщений: 31
Репутация:
0
±
Замечаний:
0% ±
Excel 2013
Спасибо за помощь, работает так как нужно!
Спасибо за помощь, работает так как нужно! romkinss
Сообщение отредактировал romkinss - Вторник, 27.06.2017, 15:29
Ответить
Сообщение Спасибо за помощь, работает так как нужно! Автор - romkinss Дата добавления - 27.06.2017 в 15:27
romkinss
Дата: Вторник, 27.06.2017, 16:44 |
Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 31
Репутация:
0
±
Замечаний:
0% ±
Excel 2013
В процессе обкатки выявился баг. Если "множить" 20, 30 строк (а в итоге мне нужно обработать 5000 строк) - то макрос затирает оригинальную таблицу. Подскажите, как сделать, чтобы макрос результат выводил на отдельном листе книги?
В процессе обкатки выявился баг. Если "множить" 20, 30 строк (а в итоге мне нужно обработать 5000 строк) - то макрос затирает оригинальную таблицу. Подскажите, как сделать, чтобы макрос результат выводил на отдельном листе книги? romkinss
Сообщение отредактировал romkinss - Вторник, 27.06.2017, 17:04
Ответить
Сообщение В процессе обкатки выявился баг. Если "множить" 20, 30 строк (а в итоге мне нужно обработать 5000 строк) - то макрос затирает оригинальную таблицу. Подскажите, как сделать, чтобы макрос результат выводил на отдельном листе книги? Автор - romkinss Дата добавления - 27.06.2017 в 16:44
_Boroda_
Дата: Вторник, 27.06.2017, 17:59 |
Сообщение № 10
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16675
Репутация:
6481
±
Замечаний:
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] А вообще-то лучше используйте макрос по ссылке
Там, как оказалось, под 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_
Скажи мне, кудесник, любимец ба’гов... Платная помощь: 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
Группа: Друзья
Ранг: Старожил
Сообщений: 1588
Репутация:
192
±
Замечаний:
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]
мой вариант [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
вот вам барабан яд 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