Excel VBA Макросы: Разбивка столбца на три столбца.

[iamalwaysnear]

Имеем множество ячеек с данными. Все они в столбце А.
Необходимо в ячейке А1 оставить первые 4 значения, остальное перенести в ячейку B1.
Ячейку A2 перенести в ячейку C1.
Повторить для всех остальных.

Наглядно вот так:
Было: A1=3637 Тема обсуждения. A2=В процессе
Должно стать: A1=3637 B1=Тема обсуждения. C1=В процессе

Изменения требуется вносить в каждую пару строк до конца документа.





[вложение удалено администратором]

[Администратор]

Вверх модуля вставьте эти строки:
Option Explicit
Option Compare Text
Option Base 1

Макрос

Sub Макрос()

    Dim src(), res()
    Dim lr As Long, r As Long, i As Long
   
   
    '1. Копируем данные из столбца A в массив "src". С массивом макрос быстрее работает,
        ' чем с эксель-ячейками.
        ' End не ищет в скрытых строках.
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    src() = Range("A1:A" & lr).Value
   
    '2. Создание ячеек в массиве "res". Сначала в него запишем данные, а затем
        ' массив вставим на лист. Это быстрее, чем писать данные в эксель-ячейки.
    ReDim res(UBound(src), 3)
   
    '3. Копирование данных из массива "src" в массив "res".
    For i = 1 To UBound(src) Step 2
       
        ' Переходим на следующую строку в массиве "res".
        r = r + 1
       
        ' Копирование данных из массива "src" в массив "res".
        res(r, 1) = Left(src(i, 1), 4)
        res(r, 2) = LTrim(Mid(src(i, 1), 5))
        res(r, 3) = src(i + 1, 1)
       
    Next i
   
    '4. Вставка массива "res" на лист.
    Range("A1").Resize(UBound(res, 1), UBound(res, 2)).Value = res()
   
    '5. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub

[свернуть]

[iamalwaysnear]

Спасибо огромное! Работает!