Есть большой файл с большим количеством характеристик товаров. Сейчас все характеристики хранятся в одной ячейке. Необходимо разбить данные ячейки по столбцам и внести нужные данные в них. У всех товаров характеристики разные. Пример файл приведен в приложении.
Есть большой файл с большим количеством характеристик товаров. Сейчас все характеристики хранятся в одной ячейке. Необходимо разбить данные ячейки по столбцам и внести нужные данные в них. У всех товаров характеристики разные. Пример файл приведен в приложении.mts2050
Public Function MyExtract(S, Attr As String) As String L = Len(S) L1 = InStr(S, Attr) If L1 = 0 Then Exit Function S = Trim(Right(S, L - L1 + 1)) L2 = InStr(S, vbLf) If L2 > 0 Then S = Left(S, L2 - 1) MyExtract = Replace(S, Attr & ":", "") End Function
[/vba]
Ловите, проверяйте. Через UDF
[vba]
Код
Public Function MyExtract(S, Attr As String) As String L = Len(S) L1 = InStr(S, Attr) If L1 = 0 Then Exit Function S = Trim(Right(S, L - L1 + 1)) L2 = InStr(S, vbLf) If L2 > 0 Then S = Left(S, L2 - 1) MyExtract = Replace(S, Attr & ":", "") End Function
А можно как то что бы он сам находил характеристики которые есть (их более 1000, вручную их искать проблематично)? Либо как их можно пересортировать в столбцы что бы потом уже заюзать данные функции?
А можно как то что бы он сам находил характеристики которые есть (их более 1000, вручную их искать проблематично)? Либо как их можно пересортировать в столбцы что бы потом уже заюзать данные функции?mts2050
Вот наваял, сразу предупреждаю - полуфабрикат, толком не оттестенный. Но и задача не совсем тривиальная
[vba]
Код
Public Function JoinS(RR As Range) As String For Each R In RR JoinS = JoinS & R.Value If Right(JoinS, 1) <> vbLf Then JoinS = JoinS & vbLf Next End Function
Public Function MyExtract(S, Attr As String) As String L = Len(S) L1 = InStr(S, Attr) If L1 = 0 Then Exit Function S = Trim(Right(S, L - L1 + 1)) L2 = InStr(S, vbLf) If L2 > 0 Then S = Left(S, L2 - 1) MyExtract = Replace(S, Attr & ":", "") End Function
Public Function ExtrN(S As String, N As Long) As String Dim SS() As String Dim SSS() As String SS = Split(S, vbLf) SSS = Split(SS(N - 1), ":") ExtrN = Trim(SSS(0)) End Function
[/vba]
Файл ПЕРЕВЛОЖИЛ, добавил на втором листе автоматизации
Вот наваял, сразу предупреждаю - полуфабрикат, толком не оттестенный. Но и задача не совсем тривиальная
[vba]
Код
Public Function JoinS(RR As Range) As String For Each R In RR JoinS = JoinS & R.Value If Right(JoinS, 1) <> vbLf Then JoinS = JoinS & vbLf Next End Function
Public Function MyExtract(S, Attr As String) As String L = Len(S) L1 = InStr(S, Attr) If L1 = 0 Then Exit Function S = Trim(Right(S, L - L1 + 1)) L2 = InStr(S, vbLf) If L2 > 0 Then S = Left(S, L2 - 1) MyExtract = Replace(S, Attr & ":", "") End Function
Public Function ExtrN(S As String, N As Long) As String Dim SS() As String Dim SSS() As String SS = Split(S, vbLf) SSS = Split(SS(N - 1), ":") ExtrN = Trim(SSS(0)) End Function
[/vba]
Файл ПЕРЕВЛОЖИЛ, добавил на втором листе автоматизацииabtextime
Конечно, надо допилить функцию ExtrN, чтобы выдавала не просто N-й атрибут, но N-й УНИКАЛЬНЫЙ атрибут. Не так сложно, но уже нет времени. Или ждите до понедельника, или кто-то шаркнет рашпилем.
Выход простой даже для такого макроса - Ctrl-C - Ctrl-V-"Значения", Данные - Удалить дубликаты
Наверное, можно и формулами сделать эту задачу, но тут уж я умываю руки
Важное уточнение.
Конечно, надо допилить функцию ExtrN, чтобы выдавала не просто N-й атрибут, но N-й УНИКАЛЬНЫЙ атрибут. Не так сложно, но уже нет времени. Или ждите до понедельника, или кто-то шаркнет рашпилем.
Выход простой даже для такого макроса - Ctrl-C - Ctrl-V-"Значения", Данные - Удалить дубликаты
Наверное, можно и формулами сделать эту задачу, но тут уж я умываю рукиabtextime
Как обещал, доделал для выборки уникального атрибута [vba]
Код
Public Function JoinS(RR As Range) As String For Each R In RR JoinS = JoinS & R.Value If Right(JoinS, 1) <> vbLf Then JoinS = JoinS & vbLf Next End Function
Public Function MyExtract(S, Attr As String) As String L = Len(S) L1 = InStr(S, Attr) If L1 = 0 Then Exit Function S = Trim(Right(S, L - L1 + 1)) L2 = InStr(S, vbLf) If L2 > 0 Then S = Left(S, L2 - 1) MyExtract = Replace(S, Attr & ":", "") End Function
Public Function ExtrN(S As String, N As Long) As String Dim SS() As String Dim SSS() As String SS = Split(S, vbLf) SSS = Split(SS(N - 1), ":") ExtrN = Trim(SSS(0)) End Function
Public Function MyUniq(R As Range, N As Long) As String
M = 0
For i = 1 To R.Rows.Count Found = False For j = 1 To i - 1 If R.Cells(i, 1).Value = R.Cells(j, 1).Value Then Found = True Exit For End If Next j If Not Found Or i = 1 Then M = M + 1 If M = N Then MyUniq = R.Cells(i, 1).Value Exit Function End If End If Next i
End Function
[/vba]
Как обещал, доделал для выборки уникального атрибута [vba]
Код
Public Function JoinS(RR As Range) As String For Each R In RR JoinS = JoinS & R.Value If Right(JoinS, 1) <> vbLf Then JoinS = JoinS & vbLf Next End Function
Public Function MyExtract(S, Attr As String) As String L = Len(S) L1 = InStr(S, Attr) If L1 = 0 Then Exit Function S = Trim(Right(S, L - L1 + 1)) L2 = InStr(S, vbLf) If L2 > 0 Then S = Left(S, L2 - 1) MyExtract = Replace(S, Attr & ":", "") End Function
Public Function ExtrN(S As String, N As Long) As String Dim SS() As String Dim SSS() As String SS = Split(S, vbLf) SSS = Split(SS(N - 1), ":") ExtrN = Trim(SSS(0)) End Function
Public Function MyUniq(R As Range, N As Long) As String
M = 0
For i = 1 To R.Rows.Count Found = False For j = 1 To i - 1 If R.Cells(i, 1).Value = R.Cells(j, 1).Value Then Found = True Exit For End If Next j If Not Found Or i = 1 Then M = M + 1 If M = N Then MyUniq = R.Cells(i, 1).Value Exit Function End If End If Next i