Здравствуйте, очень нужна помощь по данному вопросу. В ячеках есть данные с разделителем "&", надо чтоб значение после разделителя переносилось на новую строку. Есть макрос который это делает, но он делает это по одному столбцу, нужно чтоб он обробатывал сразу несколько столбцов. Вот пример макроса: [vba]
Код
Sub SplitcellD() Dim arrS() As String Dim i& For i = Cells(Rows.Count, "D").End(xlUp).Row To 1 Step -1 arrS = Split(Cells(i, "D").Value, "&" & vbLf) If UBound(arrS) > 0 Then Range(Rows(i + 1), Rows(i + UBound(arrS))).Insert Cells(i, "D").Resize(UBound(arrS) + 1).Value = Application.Transpose(arrS) End If Next i End Sub
[/vba]
Здравствуйте, очень нужна помощь по данному вопросу. В ячеках есть данные с разделителем "&", надо чтоб значение после разделителя переносилось на новую строку. Есть макрос который это делает, но он делает это по одному столбцу, нужно чтоб он обробатывал сразу несколько столбцов. Вот пример макроса: [vba]
Код
Sub SplitcellD() Dim arrS() As String Dim i& For i = Cells(Rows.Count, "D").End(xlUp).Row To 1 Step -1 arrS = Split(Cells(i, "D").Value, "&" & vbLf) If UBound(arrS) > 0 Then Range(Rows(i + 1), Rows(i + UBound(arrS))).Insert Cells(i, "D").Resize(UBound(arrS) + 1).Value = Application.Transpose(arrS) End If Next i End Sub
В таком случаае, каждый столбец опускается ниже предыдущего лесенкой получается. Хотелось бы чтоб все значения оставались друг на против друга как это сейчас в файле, только с разбивкой по строкам.
В таком случаае, каждый столбец опускается ниже предыдущего лесенкой получается. Хотелось бы чтоб все значения оставались друг на против друга как это сейчас в файле, только с разбивкой по строкам.Kravets
Sub Splitcells() Dim arrS$(), i&, rcur&, rmax& For i = 2 To 6 'цикл по колонкам arrS = Split(Cells(1, i).Value, "&" & vbLf) rcur = UBound(arrS) + 1 If rcur > rmax Then Rows(2 + rmax).Resize(rcur - rmax).Insert Cells(2, i).Resize(rcur).Value = Application.Transpose(arrS) rmax = WorksheetFunction.Max(rcur, rmax) Next i End Sub
[/vba]
У меня нечто такое получилось: [vba]
Код
Sub Splitcells() Dim arrS$(), i&, rcur&, rmax& For i = 2 To 6 'цикл по колонкам arrS = Split(Cells(1, i).Value, "&" & vbLf) rcur = UBound(arrS) + 1 If rcur > rmax Then Rows(2 + rmax).Resize(rcur - rmax).Insert Cells(2, i).Resize(rcur).Value = Application.Transpose(arrS) rmax = WorksheetFunction.Max(rcur, rmax) Next i End Sub
Sub Splitcells3() Dim arrS$(), i&, j&, rcur&, rmax&, r& r = 1 For j = 1 To 3 'цикл по исходным строкам rmax = 0 For i = 2 To 6 'цикл по колонкам arrS = Split(Cells(r, i).Value, "&" & vbLf) rcur = UBound(arrS) + 1 If rcur > rmax Then Rows(r + 1 + rmax).Resize(rcur - rmax).Insert Cells(r + 1, i).Resize(rcur).Value = Application.Transpose(arrS) rmax = WorksheetFunction.Max(rcur, rmax) Next i r = r + 1 + rmax Next j End Sub
[/vba] А если надо чтобы новые строки полностью заменяли исходные, то так: [vba]
Код
Sub Splitcells4() Dim arrS$(), i&, j&, rcur&, rmax&, r& r = 1 For j = 1 To 3 'цикл по исходным строкам rmax = 0 For i = 2 To 6 'цикл по колонкам arrS = Split(Cells(r, i).Value, "&" & vbLf) rcur = UBound(arrS) + 1 If rcur > rmax Then Rows(r + 1 + rmax).Resize(rcur - rmax).Insert Cells(r + 1, i).Resize(rcur).Value = Application.Transpose(arrS) rmax = WorksheetFunction.Max(rcur, rmax) Next i Rows(r).Delete 'ЭТО ДОБАВИЛОСЬ r = r + rmax 'А ЭТО ИЗМЕНИЛОСЬ Next j End Sub
[/vba]
Для нескольких исходных строк: [vba]
Код
Sub Splitcells3() Dim arrS$(), i&, j&, rcur&, rmax&, r& r = 1 For j = 1 To 3 'цикл по исходным строкам rmax = 0 For i = 2 To 6 'цикл по колонкам arrS = Split(Cells(r, i).Value, "&" & vbLf) rcur = UBound(arrS) + 1 If rcur > rmax Then Rows(r + 1 + rmax).Resize(rcur - rmax).Insert Cells(r + 1, i).Resize(rcur).Value = Application.Transpose(arrS) rmax = WorksheetFunction.Max(rcur, rmax) Next i r = r + 1 + rmax Next j End Sub
[/vba] А если надо чтобы новые строки полностью заменяли исходные, то так: [vba]
Код
Sub Splitcells4() Dim arrS$(), i&, j&, rcur&, rmax&, r& r = 1 For j = 1 To 3 'цикл по исходным строкам rmax = 0 For i = 2 To 6 'цикл по колонкам arrS = Split(Cells(r, i).Value, "&" & vbLf) rcur = UBound(arrS) + 1 If rcur > rmax Then Rows(r + 1 + rmax).Resize(rcur - rmax).Insert Cells(r + 1, i).Resize(rcur).Value = Application.Transpose(arrS) rmax = WorksheetFunction.Max(rcur, rmax) Next i Rows(r).Delete 'ЭТО ДОБАВИЛОСЬ r = r + rmax 'А ЭТО ИЗМЕНИЛОСЬ Next j End Sub
Спасибо большое за помощь, еще один вопрос как сделать чтоб удалялись неотформатированые данные. А то сейчас остаются значения в одной строке и ниже т же значения разбиты по строкам
Спасибо большое за помощь, еще один вопрос как сделать чтоб удалялись неотформатированые данные. А то сейчас остаются значения в одной строке и ниже т же значения разбиты по строкамKravets
Sub Splitcells4() Dim arrS$(), i&, j&, rcur&, rmax&, r& r = 1 For j = 1 To 3 'цикл по исходным строкам rmax = 0 For i = 2 To 6 'цикл по колонкам arrS = Split(Cells(r, i).Value, "&" & vbLf) rcur = UBound(arrS) + 1 If rcur > rmax Then Rows(r + 1 + rmax).Resize(rcur - rmax).Insert Cells(r + 1, i).Resize(rcur).Value = Application.Transpose(arrS) rmax = WorksheetFunction.Max(rcur, rmax) Next i Rows®.Delete 'ЭТО ДОБАВИЛОСЬ r = r + rmax 'А ЭТО ИЗМЕНИЛОСЬ Next j End Sub
Sub Splitcells4() Dim arrS$(), i&, j&, rcur&, rmax&, r& r = 1 For j = 1 To 3 'цикл по исходным строкам rmax = 0 For i = 2 To 6 'цикл по колонкам arrS = Split(Cells(r, i).Value, "&" & vbLf) rcur = UBound(arrS) + 1 If rcur > rmax Then Rows(r + 1 + rmax).Resize(rcur - rmax).Insert Cells(r + 1, i).Resize(rcur).Value = Application.Transpose(arrS) rmax = WorksheetFunction.Max(rcur, rmax) Next i Rows®.Delete 'ЭТО ДОБАВИЛОСЬ r = r + rmax 'А ЭТО ИЗМЕНИЛОСЬ Next j End Sub
Спасибо! Все работает именно так как нужно было!Kravets
Сообщение отредактировал Kravets - Понедельник, 08.12.2014, 15:04