Sub КонвертС6()
'Определение пути текущего файла
Dim PathFile As String
PathFile = ActiveWorkbook.Path
'Отключение обновления экрана
Application.ScreenUpdating = False
'Вывод формы с сообщением
Dim frmMsg As UserForm1
Set frmMsg = New UserForm1
frmMsg.Show vbModeless
DoEvents
'Объявление переменных
Dim Fam As String, Im As String, Otch As String, Ul As String, Dom As String, Kv As String, Gor As String, Pos As String, Ind As String, Ind2 As String
'Ввод данных для физ.лиц
If ActiveSheet.Name = "Физ.лица" Then
With ActiveWorkSheet
Fam = Cells(ActiveCell.Row, 1).Text
Im = Cells(ActiveCell.Row, 2).Text
Otch = Cells(ActiveCell.Row, 3).Text
'Адрес
Ind = Cells(ActiveCell.Row, 4).Text
Ind2 = "-" & Cells(ActiveCell.Row, 4).Text
Gor = Cells(ActiveCell.Row, 5).Text
Pos = Cells(ActiveCell.Row, 6).Text
Ul = Cells(ActiveCell.Row, 7).Text
Dom = Cells(ActiveCell.Row, 8).Text
Kv = Cells(ActiveCell.Row, 9).Text
End With
'Ввод данных для юридических лиц
Else
With ActiveWorkSheet
'Адрес
Fam = Cells(ActiveCell.Row, 1).Text
Ind = Cells(ActiveCell.Row, 2).Text
Ind2 = "-" & Cells(ActiveCell.Row, 2).Text
Gor = Cells(ActiveCell.Row, 3).Text
Pos = Cells(ActiveCell.Row, 4).Text
Ul = Cells(ActiveCell.Row, 5).Text
Dom = Cells(ActiveCell.Row, 6).Text
Kv = Cells(ActiveCell.Row, 7).Text
End With
End If
'Создание нового файла для конверта
With Application
.SheetsInNewWorkbook = 1
End With
Workbooks.Add
Sheets("Лист1").Select
Sheets("Лист1").Name = "КонвертС6"
'Параметры страницы
With Sheets("КонвертС6").PageSetup
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.Orientation = xlLandscape
.PaperSize = xlPaperEnvelopeC6
.Zoom = 100
.CenterHorizontally = True
.CenterVertically = True
End With
'Задание ширины столбцов и высоты строк
With Sheets("КонвертС6")
Columns("A:A").ColumnWidth = 8.22
Columns("B:B").ColumnWidth = 8.22
Columns("C:C").ColumnWidth = 8.22
Columns("D:D").ColumnWidth = 8.22
Columns("E:E").ColumnWidth = 5.11
Columns("F:F").ColumnWidth = 11.89
Columns("G:G").ColumnWidth = 23.11
Rows("1:1").RowHeight = 13.2
Rows("2:2").RowHeight = 13.2
Rows("3:3").RowHeight = 13.2
Rows("4:4").RowHeight = 13.2
Rows("5:5").RowHeight = 13.2
Rows("6:6").RowHeight = 13.2
Rows("7:7").RowHeight = 13.2
Rows("8:8").RowHeight = 13.2
Rows("9:9").RowHeight = 13.2
Rows("10:10").RowHeight = 13.2
Rows("11:11").RowHeight = 13.2
Rows("12:12").RowHeight = 13.2
Rows("13:13").RowHeight = 18.6
Rows("14:14").RowHeight = 18.6
Rows("15:15").RowHeight = 18.6
Rows("16:16").RowHeight = 18.6
Rows("17:17").RowHeight = 18.6
Rows("18:18").RowHeight = 18.6
Rows("19:19").RowHeight = 19.2
Rows("20:20").RowHeight = 13.2
Rows("21:21").RowHeight = 13.2
End With
'Вводим фиксированные данные
Range("КонвертС6!E13").FormulaR1C1 = "Кому"
Range("КонвертС6!E15").FormulaR1C1 = "Куда"
'Задаем шрифт
With Range("КонвертС6!E13,КонвертС6!E15").Font
.Name = "Arial"
.Size = 9
.Bold = True
.Italic = True
End With
'Границы и подчеркивание
'Подчеркивание строк получателя
With Range("КонвертС6!F13:G13,КонвертС6!E14:G14,КонвертС6!F15:G15,КонвертС6!E16:G16,КонвертС6!E17:G17,КонвертС6!E18:G18").Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Вставка ФИО и адреса получателя
Range("КонвертС6!F13") = Fam & " " & Im
Range("КонвертС6!F14") = Otch
Range("КонвертС6!F15") = "обл.Свердловская,"
If Pos = Empty Then
Range("КонвертС6!F16") = "г." & Gor & ","
Else
Range("КонвертС6!F16") = "г." & Gor & ", пос." & Pos & ","
End If
Range("КонвертС6!F17") = "ул." & Ul & ","
If Kv = Empty Then
Range("КонвертС6!F18") = "д." & Dom
Else
Range("КонвертС6!F18") = "д." & Dom & ", к." & Kv
End If
'Задаем шрифт
With Range("КонвертС6!F13,КонвертС6!F14,КонвертС6!F15,КонвертС6!F16,КонвертС6!F17,КонвертС6!F18").Font
.Name = "Courier New"
.Size = 10
.Bold = False
End With
'Ввод индекса получателя
Range("КонвертС6!E19").FormulaR1C1 = Ind
'Объединение ячеек
Range("КонвертС6!E19:F19").Merge
'Задание 4-х границ ячеек и выравнивание по центру
With Range("КонвертС6!E19:F19").Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Range("КонвертС6!E19:F19").Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Range("КонвертС6!E19:F19").Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Range("КонвертС6!E19:F19").Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("КонвертС6!E19:F19").Borders(xlInsideVertical).LineStyle = xlNone
With Range("КонвертС6!E19:F19")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With Range("КонвертС6!E19:F19").Font
.Name = "Courier New"
.Size = 14
.Bold = False
End With
'Формирование большого индекса получателя
Range("КонвертС6!A19").FormulaR1C1 = Ind2
Range("КонвертС6!A19:D21").Merge
With Range("КонвертС6!A19:D21").Font
.Name = "ZIPcode"
.Size = 47
.Bold = False
End With
With Range("КонвертС6!A19:D21")
.HorizontalAlignment = xlCenter
End With
'Скрытие столбцов и строк
Columns("H:IV").EntireColumn.Hidden = True
Rows("22:65536").EntireRow.Hidden = True
'Отключение сетки
Sheets("КонвертС6").Select
ActiveWindow.DisplayGridlines = False
'Убираем форму
Unload frmMsg
Set frmMsg = Nothing
'MsgBox "Готово!"
'Запрос о сохранении
Otvet = MsgBox("Сохранить документ?", vbYesNo)
Select Case Otvet
Case vbYes
'Сохранение
Dim FName As String
FName = InputBox("Введите имя файла:")
'ChDir "F:\VisualBasic\Каталог"
ActiveWorkbook.SaveAs Filename:=PathFile & "\Каталог\" & FName, FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
'Переход к файлу Конверты
' "Windows("Книга2").Activate
' Гиперссылка Макрос
Windows("Конверты").Activate
Sheets("Каталог").Activate
'Поиск первой пустой ячейки в столбце А
Range("A1").Activate
Do While Not IsEmpty(ActiveCell.Value)
ActiveCell.Offset(1, 0).Select
Loop
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=PathFile & "\Каталог\" & FName & ".xls", _
TextToDisplay:=FName & " Конверт С6"
Case vbNo
End Select
'Предварительный просмотр
' ActiveWindow.SelectedSheets.PrintPreview
End Sub