Разнести данные 1 столбца на несколько

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Разнести данные 1 столбца на несколько (Макросы/Sub)

anna111

Дата: Суббота, 22.03.2014, 22:04 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 4

Репутация: 0 ±

Замечаний: 20% ±

Excel 2007

Добрый вечер! Помогите разбить 1 столбец на 5.
Изготовитель1
Заказчик1
Заказ1
Сумма1
Дата1
Изготовитель2
Заказчик2
Заказ2
Сумма2
Дата2
Должен быть вид конечной таблицы(шапка) Изготовитель Заказчик Заказ Сумма Дата
Нашла интересный код у вас на сайте, который подходит и работает, но проблема в том, что "Изготовитель,Заказчик и заказ оформлены в виде гиперссылки, а сумма и дата в виде текста. Хотелось бы формат сохранить, но данный код делает все, кроме 1 столбца текстом. Код таков:
[vba]

Код

Sub Макрос()
Dim i As Long, r As Long, n As Variant
n = InputBox("Введите количество столбцов," & Chr(10) & "на которое разбить столбец А", _
"Ввод количества столбцов", 5)
If n <> "" Then
Application.ScreenUpdating = False
Dim MyArray As Variant, CArray() ' As Long
r = Int(1 + Columns(1).End(xlDown).Row / n)
ReDim CArray(1 To r, 1 To n)
MyArray = Range("A1:A" & Columns(1).End(xlDown).Row).Value
For i = 1 To UBound(MyArray)
CArray(Int((i + n - 1) / n), ((i - 1) Mod n) + 1) = MyArray(i, 1)
Next i
Range("A1:A" & Columns(1).End(xlDown).Row).ClearContents
Range("A1").Resize(r, n) = CArray()
Application.ScreenUpdating = True
End If
End Sub

[/vba]