20171114xlVba选定单行记录并打印

Posted 2020-10-14 Excel VBA 小天地

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