Макрос для объединения ячеек в Excel

[Vadim Lisovec]

Здравствуйте!
Очень нужен макрос для объединения ячеек в Excel 2003 "Windows XP"
Пример как должен работать на изображении!
Помогите пожалуйста кто может
Заранее СПАСИБО!

[Hugo121]

Минимально дополнил записанное рекордером:

Sub Macro1()
'
' Macro1 Macro
' Macro recorded 20.08.2013 by IB
'

'
    Dim a()
    Application.DisplayAlerts = False
    Range("A1:A2").Select
    a = Selection.Value
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Selection.Value = Join(Application.Transpose(a), Chr(10))
    Range("B1:B2").Select
    a = Selection.Value
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Selection.Value = Join(Application.Transpose(a), Chr(10))
    Range("C1:C2").Select
    a = Selection.Value
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Selection.Value = Join(Application.Transpose(a), Chr(10))
    Application.DisplayAlerts = True
End Sub

[Vadim Lisovec]

Спасибо большое очень помогло
ОГРОМНОЕ СПАСИБО !!!

[Hugo121]

Чуть пооптимизировал:

Sub Macro2()
    Dim a()
    Application.DisplayAlerts = False
    With Range("A1:A2")
        a = .Value: .MergeCells = True
        .Value = Join(Application.Transpose(a), Chr(10))
    End With
    With Range("B1:B2")
        a = .Value: .MergeCells = True
        .Value = Join(Application.Transpose(a), Chr(10))
    End With
    With Range("C1:C2")
        a = .Value: .MergeCells = True
        .Value = Join(Application.Transpose(a), Chr(10))
    End With
    Application.DisplayAlerts = True
End Sub

[Vadim Lisovec]

Блин нужно для 6 столбцов !!!

[Vadim Lisovec]

вот такой вид имеет мой документ мне нежно что бы все 6 столбцов

[Hugo121]

А что, в коде не можете найти где прописаны диапазоны?

[Vadim Lisovec]

К сожалению нет я не селен в этом !
Если вам не трудно помогите еще раз пожалуйста !
еще нужно что бы не для одной строки а для всех, и для 6 столбцов

[Hugo121]

Трудно.
Трудно и файл делать, и понять, что именно нужно.

[Vadim Lisovec]

Я извиняюсь за то что надоедаю ну просто очень нужен такой макрос, нужен для того что бы объединялись все строки и все 6 столбцов!
Что бы имело все такой вид