Коллеги, добрый день. Есть проблема с параметрами наименований, которые идут в различном формате. Где-то через зпт, где-то через дефиз, где-то вперемежку. Некоторыми скриптами я разбиваю данные из одной ячейки на несколько и транспонированием вставляю цифры в столбец, но это довольно затратно по времени + наименование и др параметры приходится вручную растягивать вниз.
Пример прилагаю. Есть какая-то простая возможность реализации необходимого?
Коллеги, добрый день. Есть проблема с параметрами наименований, которые идут в различном формате. Где-то через зпт, где-то через дефиз, где-то вперемежку. Некоторыми скриптами я разбиваю данные из одной ячейки на несколько и транспонированием вставляю цифры в столбец, но это довольно затратно по времени + наименование и др параметры приходится вручную растягивать вниз.
Пример прилагаю. Есть какая-то простая возможность реализации необходимого?VadimVV
спер макрос тут, немного потанцевал вокруг него с бубном [vba]
Код
Public Sub Spl() Dim x, n&, i& Dim arr(), qwe() If Selection.Columns.Count > 1 Then Exit Sub Application.ScreenUpdating = 0 n& = Selection.Rows.Count For i = n To 1 Step -1 With Selection(i) x = Split(.Value, ", ") Dim r$: r = IIf(Application.ReferenceStyle = xlR1C1, "r", "") ReDim arr(0) Dim m&: m = 0 For Each qq In x m = m + 1 On Error Resume Next qwe = Evaluate("row(" & Replace(qq, "-", r & ":") & IIf(InStr(1, qq, "-"), "", r & ":" & qq) & ")") ReDim Preserve arr(UBound(arr) + UBound(qwe) + (m = 1)) For j = UBound(qwe) To 1 Step -1 arr(UBound(arr) - j + 1) = Application.Transpose(qwe)(UBound(qwe) - j + 1) Next Next If Len(.Value) * UBound(arr) And Err.Number = 0 Then Rows(.Row).Offset(1, 0).Resize(UBound(arr)).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow .EntireRow.Copy Rows(.Row).Offset(1, 0).Resize(UBound(arr)) Range(.Address).Resize(UBound(arr) + 1, 1).Value = WorksheetFunction.Transpose(arr) End If End With Next Application.ScreenUpdating = 1 End Sub
[/vba] выделяете C2:C3, жмете на кнопку
спер макрос тут, немного потанцевал вокруг него с бубном [vba]
Код
Public Sub Spl() Dim x, n&, i& Dim arr(), qwe() If Selection.Columns.Count > 1 Then Exit Sub Application.ScreenUpdating = 0 n& = Selection.Rows.Count For i = n To 1 Step -1 With Selection(i) x = Split(.Value, ", ") Dim r$: r = IIf(Application.ReferenceStyle = xlR1C1, "r", "") ReDim arr(0) Dim m&: m = 0 For Each qq In x m = m + 1 On Error Resume Next qwe = Evaluate("row(" & Replace(qq, "-", r & ":") & IIf(InStr(1, qq, "-"), "", r & ":" & qq) & ")") ReDim Preserve arr(UBound(arr) + UBound(qwe) + (m = 1)) For j = UBound(qwe) To 1 Step -1 arr(UBound(arr) - j + 1) = Application.Transpose(qwe)(UBound(qwe) - j + 1) Next Next If Len(.Value) * UBound(arr) And Err.Number = 0 Then Rows(.Row).Offset(1, 0).Resize(UBound(arr)).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow .EntireRow.Copy Rows(.Row).Offset(1, 0).Resize(UBound(arr)) Range(.Address).Resize(UBound(arr) + 1, 1).Value = WorksheetFunction.Transpose(arr) End If End With Next Application.ScreenUpdating = 1 End Sub
Последний макрос работает, но, почему-то не хочет разделять некоторые данные. В моей исходной таблице порядка тысячи строк с таким форматом данных. Вот часть данных макрос верно обрабатывает, а часть - не обрабатывает вовсе.
Пример прилагаю. Но интересность ещё в том, что если я вообще перенесу эти данные в новый файл, то макрос работает.
Последний макрос работает, но, почему-то не хочет разделять некоторые данные. В моей исходной таблице порядка тысячи строк с таким форматом данных. Вот часть данных макрос верно обрабатывает, а часть - не обрабатывает вовсе.
Пример прилагаю. Но интересность ещё в том, что если я вообще перенесу эти данные в новый файл, то макрос работает.VadimVV
Public Sub Spl() Dim x, n&, i& Dim arr(), qwe() If Selection.Columns.Count > 1 Then Exit Sub Application.ScreenUpdating = 0 n& = Selection.Rows.Count For i = n To 1 Step -1 With Selection(i) x = Split(.Value, ", ") Dim r$: r = IIf(Application.ReferenceStyle = xlR1C1, "r", "") ReDim arr(0) Dim m&: m = 0 For Each qq In x m = m + 1 'On Error Resume Next qwe = Evaluate("row(" & r & "1:" & r & IIf(InStr(1, qq, "-"), Abs(Evaluate(qq)) + 1, 1) & ")-1+" & Split(qq, "-")(0)) ReDim Preserve arr(UBound(arr) + UBound(qwe) + (m = 1)) For j = UBound(qwe) To 1 Step -1 arr(UBound(arr) - j + 1) = WorksheetFunction.Transpose(qwe)(UBound(qwe) - j + 1) Next Next If Len(.Value) * UBound(arr) And Err.Number = 0 Then Rows(.Row).Offset(1, 0).Resize(UBound(arr)).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow .EntireRow.Copy Rows(.Row).Offset(1, 0).Resize(UBound(arr)) Range(.Address).Resize(UBound(arr) + 1, 1).Value = WorksheetFunction.Transpose(arr) End If End With Next Application.ScreenUpdating = 1 End Sub
[/vba]
проверяйте [vba]
Код
Public Sub Spl() Dim x, n&, i& Dim arr(), qwe() If Selection.Columns.Count > 1 Then Exit Sub Application.ScreenUpdating = 0 n& = Selection.Rows.Count For i = n To 1 Step -1 With Selection(i) x = Split(.Value, ", ") Dim r$: r = IIf(Application.ReferenceStyle = xlR1C1, "r", "") ReDim arr(0) Dim m&: m = 0 For Each qq In x m = m + 1 'On Error Resume Next qwe = Evaluate("row(" & r & "1:" & r & IIf(InStr(1, qq, "-"), Abs(Evaluate(qq)) + 1, 1) & ")-1+" & Split(qq, "-")(0)) ReDim Preserve arr(UBound(arr) + UBound(qwe) + (m = 1)) For j = UBound(qwe) To 1 Step -1 arr(UBound(arr) - j + 1) = WorksheetFunction.Transpose(qwe)(UBound(qwe) - j + 1) Next Next If Len(.Value) * UBound(arr) And Err.Number = 0 Then Rows(.Row).Offset(1, 0).Resize(UBound(arr)).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow .EntireRow.Copy Rows(.Row).Offset(1, 0).Resize(UBound(arr)) Range(.Address).Resize(UBound(arr) + 1, 1).Value = WorksheetFunction.Transpose(arr) End If End With Next Application.ScreenUpdating = 1 End Sub
К сожалению, лс недоступно до набора 100 сообщений. Давайте через почту тогда [moder]адрес я отсюда удалил, а Андрею отправил копию этого письма с адресом в личном сообщении.
К сожалению, лс недоступно до набора 100 сообщений. Давайте через почту тогда [moder]адрес я отсюда удалил, а Андрею отправил копию этого письма с адресом в личном сообщении.VadimVV
Исключительно в целях упражнения сделал свой вариант. Для любителей просматривать код замечу, что программа усложнена намеренно - её можно ускорить почти в 2 раза если пропустить промежуточный массив (из двух циклов for сделать один). Основная часть кода:
[vba]
Код
Sub Rio_Roll()
Dim ArrA Dim ArrX As Basic_Data Dim StrX As String Dim RowX As Long Dim Size As Long Dim a As Long Dim i As Long Dim j As Long
a = Cells(Rows.Count, 1).End(xlUp).Row - 2 ArrA = Range(Cells(2, 1), Cells(a + 2, 6)) ReDim ArrX.Row(a)
For i = 0 To UBound(ArrX.Row) With ArrX.Row(i) .Name = ArrA(i + 1, 1) .Number = ArrA(i + 1, 2) StrX = ArrA(i + 1, 3) .Code = StrToArr_Convertor(StrX) .Amount = ArrA(i + 1, 4) .Growth = ArrA(i + 1, 5) .Date = ArrA(i + 1, 6) Size = Size + UBound(.Code) + 1 End With Next i
ReDim ArrA(Size - 1, 5)
For i = 0 To UBound(ArrX.Row) With ArrX.Row(i) For j = 0 To UBound(.Code) ArrA(RowX, 0) = .Name ArrA(RowX, 1) = .Number ArrA(RowX, 2) = .Code(j) ArrA(RowX, 3) = .Amount ArrA(RowX, 4) = .Growth ArrA(RowX, 5) = .Date RowX = RowX + 1 Next j End With Next i
Cells(2, 1).Resize(Size, 6).Value = ArrA
End Sub
[/vba]
Здравствуйте.
Исключительно в целях упражнения сделал свой вариант. Для любителей просматривать код замечу, что программа усложнена намеренно - её можно ускорить почти в 2 раза если пропустить промежуточный массив (из двух циклов for сделать один). Основная часть кода:
[vba]
Код
Sub Rio_Roll()
Dim ArrA Dim ArrX As Basic_Data Dim StrX As String Dim RowX As Long Dim Size As Long Dim a As Long Dim i As Long Dim j As Long
a = Cells(Rows.Count, 1).End(xlUp).Row - 2 ArrA = Range(Cells(2, 1), Cells(a + 2, 6)) ReDim ArrX.Row(a)
For i = 0 To UBound(ArrX.Row) With ArrX.Row(i) .Name = ArrA(i + 1, 1) .Number = ArrA(i + 1, 2) StrX = ArrA(i + 1, 3) .Code = StrToArr_Convertor(StrX) .Amount = ArrA(i + 1, 4) .Growth = ArrA(i + 1, 5) .Date = ArrA(i + 1, 6) Size = Size + UBound(.Code) + 1 End With Next i
ReDim ArrA(Size - 1, 5)
For i = 0 To UBound(ArrX.Row) With ArrX.Row(i) For j = 0 To UBound(.Code) ArrA(RowX, 0) = .Name ArrA(RowX, 1) = .Number ArrA(RowX, 2) = .Code(j) ArrA(RowX, 3) = .Amount ArrA(RowX, 4) = .Growth ArrA(RowX, 5) = .Date RowX = RowX + 1 Next j End With Next i