Добрый день. Подскажите, как заставить работать макрос? Файл
https://dropmefiles.com/dVnMA
Sub SplitCharacteristics()
Dim aData(), aHead(), aRes(), aSpl
Dim sHeader As String
Dim lRw As Long, lClmn As Long
Dim i As Long, n As Long, k As Long, p As Long, j As Long
With wsCSV ' лист с объединенными данными'
lRw = .Cells(.Rows.Count, 1).End(xlUp).Row
aData = .Range("A1:A" & lRw).Value ' объединенные данные в массив'
End With
With wsRes ' лист для выгрузки результата'
lClmn = .Cells(1, .Columns.Count).End(xlToLeft).Column
aHead = .Range("A1").Resize(1, lClmn).Value ' заголовки в массив'
End With
ReDim aRes(1 To lRw, 1 To lClmn) ' размерности массива для результата'
For i = 1 To lRw
If aData(i, 1) <> Empty Then
aSpl = Split(aData(i, 1), Chr$(10)) ' разделяем характеристики, помещаем в массив'
k = k + 1 ' строка в массиве результата'
For p = 0 To UBound(aSpl) ' проходим по характеристикам'
sHeader = Split(aSpl(p), ":")(0) ' заголовок характеристики'
For j = 1 To lClmn ' проходим по заголовкам на листе'
If aHead(1, j) = sHeader Then ' заголовок совпал'
aRes(k, j) = Split(aSpl(p), ":")(1) ' записываем характеристику'
Exit For ' выходим из цикла к следующей характеристике'
End If
Next j
Next p
End If
Next i
Application.ScreenUpdating = False
With wsRes
.Rows("2:" & .UsedRange.Rows.Count + 2).Delete 'чистим лист от старых данных'
.Range("A2").Resize(k, lClmn).Value = aRes ' выгружаем на лист новые данные'
End With
Application.ScreenUpdating = True
MsgBox "OK", 64, ""
End Sub
Простой
