Public Sub PrintSelectRow()
Dim Wb As Workbook
Dim iSht As Worksheet
Dim rSht As Worksheet
Dim pSht As Worksheet
Dim Rng As Range, ActiveRow As Long
Dim Arr As Variant, Ar As Variant
Dim EndRow As Long, EndCol As Long
Dim RngCol As Long
Set Wb = Application.ThisWorkbook
Set iSht = Wb.Worksheets("信息表")
Set rSht = Wb.Worksheets("打印记录")
Set pSht = Wb.Worksheets("打印模板") With iSht
EndCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
ActiveRow = Application.ActiveCell.Row
Set Rng = .Range(.Cells(ActiveRow, 1), .Cells(ActiveRow, EndCol))
RngCol = EndCol + 1
If Application.WorksheetFunction.CountA(Rng) = 0 Then
MsgBox "当前选中行为空白行，请重新选择！", vbInformation, "AuthorQQ 84857038"
GoTo ErrorExit
End If
Ar = Rng.Value
End With With rSht
EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
If EndRow < 1 Then
MsgBox "请在打印记录表第一行添加标题！", vbInformation, "AuthorQQ 84857038"
GoTo ErrorExit
End If Set Rng = .Range(.Cells(2, 1), .Cells(EndRow + 1, RngCol))
Arr = Rng.Value
For i = UBound(Arr) To LBound(Arr) + 1 Step -1
For j = LBound(Arr, 2) To UBound(Arr, 2)
Arr(i, j) = Arr(i - 1, j)
Next j
Next i i = 1
Arr(1, 1) = EndRow
For j = LBound(Ar) To UBound(Ar)
Arr(1, j + 1) = Ar(1, j)
Next j
Rng.Value = Arr
SetBorders .UsedRange
SetFormat .UsedRange
End With pSht.PrintOut ErrorExit:
Set iSht = Nothing
Set rSht = Nothing
Set pSht = Nothing
Set Rng = Nothing
Set Wb = Nothing End Sub
Private Sub SetBorders(ByVal Rng As Range)
With Rng.Borders
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
Private Sub SetFormat(ByVal Rng As Range)
With Rng
With .Font
.Size = 11
.Name = "宋体"
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Columns.AutoFit
End With
End Sub