mavrados » 11.12.2006 (Пн) 9:49
Sub Макрос1()
'
' Макрос1 Макрос
' Макрос записан 29.01.2002 (Vitautas)
'
Dim i As Long
Dim lngOffSet As Long
Application.ScreenUpdating = False
For i = 1 To Range("Data1").Rows.Count 'кол-во карточек
lngOffSet = (i - 1) * 28 + 1
Cells(lngOffSet, 1) = "Карточка входящего документа"
Range("A" & lngOffSet & ":I" & lngOffSet).Select
With Selection
.Merge
.HorizontalAlignment = xlCenter
With .Font
.Bold = True
.Size = 12
End With
End With
With Cells(lngOffSet + 2, 3)
.Value = "Номер входящего"
.Select
End With
Cells(lngOffSet + 2, 5) = Range("Data1").Cells(i, 1)
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
With .Font
.Bold = True
End With
End With
With Cells(lngOffSet + 4, 1)
.Value = "Корреспондент"
.Select
End With
Cells(lngOffSet + 4, 3) = Range("Data1").Cells(i, 2)
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
With .Font
.Bold = True
End With
End With
Range("C" & (lngOffSet + 4) & ":G" & (lngOffSet + 5)).Select
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = True
End With
With Cells(lngOffSet + 4, 8)
.Value = "Срок исп."
.Select
End With
Cells(lngOffSet + 4, 9) = Range("Data1").Cells(i, 3)
Cells(lngOffSet + 4, 9).NumberFormat = "dd/mm/yyyy"
With Selection
.HorizontalAlignment = xlRight
.Font.Bold = True
End With
With Cells(lngOffSet + 7, 1)
.Value = "Дата пост. и № документа"
.Select
End With
Cells(lngOffSet + 7, 4) = Range("Data1").Cells(i, 4)
With Selection
.HorizontalAlignment = xlLeft
.Font.Bold = True
End With
With Cells(lngOffSet + 7, 8)
.Value = "Дата док."
.Select
End With
Cells(lngOffSet + 7, 9) = Range("Data1").Cells(i, 5)
Cells(lngOffSet + 7, 9).NumberFormat = "dd/mm/yyyy"
With Selection
.HorizontalAlignment = xlRight
.Font.Bold = True
End With
With Cells(lngOffSet + 9, 1)
.Value = "Вид документа"
.Select
End With
Cells(lngOffSet + 9, 3) = Range("Data1").Cells(i, 6)
With Selection
.HorizontalAlignment = xlLeft
.Font.Bold = True
End With
With Cells(lngOffSet + 11, 1)
.Value = "Краткое содержание"
.Select
End With
Cells(lngOffSet + 11, 3) = Range("Data1").Cells(i, 7)
With Selection
.HorizontalAlignment = xlLeft
.Font.Bold = True
End With
Range("C" & (lngOffSet + 11) & ":I" & (lngOffSet + 12)).Select
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = True
End With
With Cells(lngOffSet + 14, 1)
.Value = "Резолюция"
.Select
Cells(lngOffSet + 14, 3) = Range("Data1").Cells(i, 8)
End With
With Selection
.HorizontalAlignment = xlLeft
.Font.Bold = True
End With
Range("C" & (lngOffSet + 14) & ":I" & (lngOffSet + 15)).Select
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = True
End With
With Cells(lngOffSet + 17, 1)
.Value = "Отметка об исполнении"
.Select
End With
Cells(lngOffSet + 17, 3) = Range("Data1").Cells(i, 9)
With Selection
.HorizontalAlignment = xlLeft
.Font.Bold = True
End With
With Cells(lngOffSet + 21, 1)
.Value = "Фонд №"
.Select
End With
With Selection
.HorizontalAlignment = xlLeft
.Font.Bold = True
End With
Range("A" & (lngOffSet + 20) & ":C" & (lngOffSet + 22)).Select
LinesSelect
With Cells(lngOffSet + 21, 4)
.Value = "Опись №"
.Select
End With
With Selection
.HorizontalAlignment = xlLeft
.Font.Bold = True
End With
Range("D" & (lngOffSet + 20) & ":F" & (lngOffSet + 22)).Select
LinesSelect
With Cells(lngOffSet + 21, 7)
.Value = "Дело №"
.Select
End With
' Cells(lngOffSet + 21, 8) = Range("Data1").Cells(i, 10)
With Selection
.HorizontalAlignment = xlLeft
.Font.Bold = True
End With
Range("G" & (lngOffSet + 20) & ":I" & (lngOffSet + 22)).Select
LinesSelect
If (i + 1) / 2 = (i + 1) \ 2 And i > 1 Then
Cells(lngOffSet, 1).Select
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
End If
Next
Application.ScreenUpdating = True
End Sub
Private Sub LinesSelect()
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub