Есть проблемка - срочно нужен макрос, позволяющий взять из ячейки текст с запятыми и создать строки, содержащие текст, находившийся между запятыми.
Например я ячейке содержится: 50319, 50349, 996, 5079, 50365, 5089, 991, 50408, 50483, 5012, 50466, 50306, 50354, 50455, 50350, 50485
Соответственно результат должен быть (без запятых, строки сразу за той, в которой исходный текст): 50319 50349 996 5079 50365 5089 991 50408 50483 5012 50466 50306 50354 50455 50350 50485
Очень прошу помочь!
P.S. В прилагаемом файле два листа: Исходные данные и Результат (как должно выглядеть, но результат должен быть на том же листе, где и исходные данные)
Уважаемые мастера, макрописатели!
Есть проблемка - срочно нужен макрос, позволяющий взять из ячейки текст с запятыми и создать строки, содержащие текст, находившийся между запятыми.
Например я ячейке содержится: 50319, 50349, 996, 5079, 50365, 5089, 991, 50408, 50483, 5012, 50466, 50306, 50354, 50455, 50350, 50485
Соответственно результат должен быть (без запятых, строки сразу за той, в которой исходный текст): 50319 50349 996 5079 50365 5089 991 50408 50483 5012 50466 50306 50354 50455 50350 50485
Очень прошу помочь!
P.S. В прилагаемом файле два листа: Исходные данные и Результат (как должно выглядеть, но результат должен быть на том же листе, где и исходные данные)VAlxB
Еще чуть бы поправить, чтобы первая результирующая строка была в исходной ячейке, а строки с результатами были новыми, вставленными. Т.е. то что под исходной строкой "уехало" вниз, а не перезаписалось результатами.
Rioran,
тоже большое спасибо!!
Еще чуть бы поправить, чтобы первая результирующая строка была в исходной ячейке, а строки с результатами были новыми, вставленными. Т.е. то что под исходной строкой "уехало" вниз, а не перезаписалось результатами.VAlxB
Сообщение отредактировал VAlxB - Пятница, 14.11.2014, 11:11
Посмотрите кнопу во вложении. Макрос Елены изящен, а мой изначально был избыточен по количеству действий. Однако мой, наверно, легче перестроить под новые условия задачи.
[vba]
Код
Sub Rio_Deployment2()
Dim X&, A&, StrX$, ArrX: StrX = Cells(1, 1).Value
For X = 1 To Len(StrX) If Mid(StrX, X, 1) = "," Then A = A + 1 Next X
ArrX = Split(StrX, ", ") Rows("2:" & A + 1).Insert
For X = 0 To A Cells(1 + X, 1).Value = ArrX(X) Next X
End Sub
[/vba]
VAlxB, Ваше желание исполнено =)
Посмотрите кнопу во вложении. Макрос Елены изящен, а мой изначально был избыточен по количеству действий. Однако мой, наверно, легче перестроить под новые условия задачи.
[vba]
Код
Sub Rio_Deployment2()
Dim X&, A&, StrX$, ArrX: StrX = Cells(1, 1).Value
For X = 1 To Len(StrX) If Mid(StrX, X, 1) = "," Then A = A + 1 Next X
ArrX = Split(StrX, ", ") Rows("2:" & A + 1).Insert
For X = 0 To A Cells(1 + X, 1).Value = ArrX(X) Next X
Public Sub Spl() Dim x x = Split(ActiveCell.Value, ",") If Len(ActiveCell.Value) Then Rows(ActiveCell.Row).Offset(1, 0).Resize(UBound(x), 1).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow Range(ActiveCell.Address).Resize(UBound(x) + 1, 1).Value = WorksheetFunction.Transpose(x) End If End Sub
Public Sub Spl() Dim x x = Split(ActiveCell.Value, ",") If Len(ActiveCell.Value) Then Rows(ActiveCell.Row).Offset(1, 0).Resize(UBound(x), 1).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow Range(ActiveCell.Address).Resize(UBound(x) + 1, 1).Value = WorksheetFunction.Transpose(x) End If End Sub
Для обработки нескольких выделенных ячеек в столбце [vba]
Код
Public Sub Spl() Dim x, n&, i& If Selection.Columns.Count > 1 Then Exit Sub n& = Selection.Rows.Count For i = n To 1 Step -1 With Selection(i) x = Split(.Value, ",") If Len(.Value) And UBound(x) Then Rows(.Row).Offset(1, 0).Resize(UBound(x)).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow Range(.Address).Resize(UBound(x) + 1, 1).Value = WorksheetFunction.Transpose(x) End If End With Next End Sub
[/vba]
Для обработки нескольких выделенных ячеек в столбце [vba]
Код
Public Sub Spl() Dim x, n&, i& If Selection.Columns.Count > 1 Then Exit Sub n& = Selection.Rows.Count For i = n To 1 Step -1 With Selection(i) x = Split(.Value, ",") If Len(.Value) And UBound(x) Then Rows(.Row).Offset(1, 0).Resize(UBound(x)).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow Range(.Address).Resize(UBound(x) + 1, 1).Value = WorksheetFunction.Transpose(x) End If End With Next End Sub
Sub sdf() Dim cell As Range, arr As Variant If Selection.Columns.Count > 1 Then Exit Sub With Application: .ScreenUpdating = 0: .EnableEvents = 0 With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") For Each cell In Selection arr = Split(cell, ", ") If UBound(arr) * Len(cell) Then cell.EntireRow.Offset(1).Resize(UBound(arr)).Insert cell.EntireRow.Copy cell.EntireRow.Offset(1).Resize(UBound(arr)) .SetText Replace(Trim(cell), ", ", Chr(10)): .PutInClipboard cell.PasteSpecial xlPasteAll End If Next End With .ScreenUpdating = 1: .EnableEvents = 1: End With End Sub
[/vba]
немного по-еврейски [vba]
Код
Sub sdf() Dim cell As Range, arr As Variant If Selection.Columns.Count > 1 Then Exit Sub With Application: .ScreenUpdating = 0: .EnableEvents = 0 With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") For Each cell In Selection arr = Split(cell, ", ") If UBound(arr) * Len(cell) Then cell.EntireRow.Offset(1).Resize(UBound(arr)).Insert cell.EntireRow.Copy cell.EntireRow.Offset(1).Resize(UBound(arr)) .SetText Replace(Trim(cell), ", ", Chr(10)): .PutInClipboard cell.PasteSpecial xlPasteAll End If Next End With .ScreenUpdating = 1: .EnableEvents = 1: End With End Sub
Так проверьте (подсмотрела немного у krosav4ig'а) [vba]
Код
Public Sub Spl() Dim x, n&, i& If Selection.Columns.Count > 1 Then Exit Sub Application.ScreenUpdating = 0 n& = Selection.Rows.Count For i = n To 0 Step -1 With Selection(i) x = Split(.Value, ",") If Len(.Value) * UBound(x) Then Rows(.Row).Offset(1, 0).Resize(UBound(x)).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow .EntireRow.Copy Rows(.Row).Offset(1, 0).Resize(UBound(x)) Range(.Address).Resize(UBound(x) + 1, 1).Value = WorksheetFunction.Transpose(x) End If End With Next Application.ScreenUpdating = 1 End Sub
[/vba]
Так проверьте (подсмотрела немного у krosav4ig'а) [vba]
Код
Public Sub Spl() Dim x, n&, i& If Selection.Columns.Count > 1 Then Exit Sub Application.ScreenUpdating = 0 n& = Selection.Rows.Count For i = n To 0 Step -1 With Selection(i) x = Split(.Value, ",") If Len(.Value) * UBound(x) Then Rows(.Row).Offset(1, 0).Resize(UBound(x)).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow .EntireRow.Copy Rows(.Row).Offset(1, 0).Resize(UBound(x)) Range(.Address).Resize(UBound(x) + 1, 1).Value = WorksheetFunction.Transpose(x) End If End With Next Application.ScreenUpdating = 1 End Sub