Avsha » 11 ноя 2006, 19:29
Хотя результат можно несколько улучшить, если воспользоваться моноширинным шрифтом, заключив таблицу в CODE
а это и есть ответ ...
перед этим в Excel выделяем диапазон, являющийся таблицей и выполняем макрос:
Код: Выделить всё
Sub Text_Fix_width()
Dim r1 As Range
Dim r2 As Range
Set r1 = Selection
Set r2 = Selection.Offset(, r1.Columns.Count + 1)
'Форматирование диапазона ячеек для вывода текста с фиксированной длиной
r2.NumberFormat = "@"
With r2.Font
.Name = "Courier New CYR"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
For j = 1 To r1.Columns.Count
'Поиск максимальной длины текста в ячейках для столбца j
MaxLen = Len(r1.Cells(1, j).Text)
For i = 1 To r1.Rows.Count
If MaxLen < Len(r1.Cells(i, j).Text) Then MaxLen = Len(r1.Cells(i, j).Text)
Next i
'Формирование текста с фиксированной длиной (+ c разделителем)
For i = 1 To r1.Rows.Count
r2.Cells(i, 1).Value = r2.Cells(i, 1).Text + _
r1.Cells(i, j).Text + _
Space(MaxLen - Len(r1.Cells(i, j).Text)) + " :"
Next i
Next j
'Форматирование диапазона ячеек для вывода текста с фиксированной длиной
r2.Columns(1).AutoFit
End Sub
результат размещаем на форуме, помещенный в CODE
[quote]Хотя результат можно несколько улучшить, если воспользоваться моноширинным шрифтом, заключив таблицу в CODE[/quote]
а это и есть ответ ...
перед этим в Excel выделяем диапазон, являющийся таблицей и выполняем макрос:
[code]Sub Text_Fix_width()
Dim r1 As Range
Dim r2 As Range
Set r1 = Selection
Set r2 = Selection.Offset(, r1.Columns.Count + 1)
'Форматирование диапазона ячеек для вывода текста с фиксированной длиной
r2.NumberFormat = "@"
With r2.Font
.Name = "Courier New CYR"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
For j = 1 To r1.Columns.Count
'Поиск максимальной длины текста в ячейках для столбца j
MaxLen = Len(r1.Cells(1, j).Text)
For i = 1 To r1.Rows.Count
If MaxLen < Len(r1.Cells(i, j).Text) Then MaxLen = Len(r1.Cells(i, j).Text)
Next i
'Формирование текста с фиксированной длиной (+ c разделителем)
For i = 1 To r1.Rows.Count
r2.Cells(i, 1).Value = r2.Cells(i, 1).Text + _
r1.Cells(i, j).Text + _
Space(MaxLen - Len(r1.Cells(i, j).Text)) + " :"
Next i
Next j
'Форматирование диапазона ячеек для вывода текста с фиксированной длиной
r2.Columns(1).AutoFit
End Sub[/code]
результат размещаем на форуме, помещенный в CODE