Каждое второе значение идущее через звёздочку перенести в соседний столбец - VBA

Формулировка задачи:

Добрый день! Имеется excel файл напечатанного ниже формата:

Столбец "C"

- категория и описание. Пример

исходника excel

файла напечатан ниже: [C1] Машина*Красная*Трактор*Серо-коричневый, номер AA88*Телефон в расрочку от 21.03.2016 03:50*Китайский от производителя [C2] Велосипед*Для города*Аэропорт*Новый Напечатайте пожалуйста макрос который каждое второе значение ячейки столбца "C", напечатает в соседней ячейки столбца "D", значения внутри ячейки должны быть разделены * (звёздочкой). Пример

необходимого результата excel

файла напечатан ниже: [C1] Машина*Трактор*Телефон в расрочку от 21.03.2016 03:50 [D1] Красная*Серо-коричневый, номер AA88*Телефон в расрочку от 21.03.2016 03:50*Китайский от производителя [C2] Велосипед*Аэропорт [D2] Для города*Новый Пример excel файла во вложении, в нём представлены страницы исходник и необходимый результат.

Решение задачи: «Каждое второе значение идущее через звёздочку перенести в соседний столбец»

textual
                            Листинг программы 
                        
 
                        
                          
                    
Private Sub Test()
    Dim iArr, tmp, tmp1$, tmp2$, iRow&, iCount&
    iArr = Range(Cells(1, 4), Cells(Rows.Count, 3).End(xlUp)).Value
    
    For iRow = 1 To UBound(iArr)
        tmp = Split(iArr(iRow, 1), "*")
        For iCount = 0 To UBound(tmp)
            If iCount Mod 2 Then
               tmp1 = tmp1 & "*" & tmp(iCount)
            Else
               tmp2 = tmp2 & "*" & tmp(iCount)
            End If
        Next
        iArr(iRow, 1) = Mid$(tmp2, 2): tmp2 = ""
        iArr(iRow, 2) = Mid$(tmp1, 2): tmp1 = ""
    Next
    Cells(1, 4).Resize(iRow - 1, 2) = iArr
End Sub