Excel VBA：每次打印后自动递增单元格值

Question

我在 EctendOffice 上找到了一个 VBA 代码，用于在每次打印后递增单元格中的数字。 现在我需要在每次打印后在同一页上增加 4 个单元格值。 示例：当我将打印数量设置为 50 时，单元格 C27 的值应为 1/50，单元格 M27 = 2/50，单元格 C58 = 3/50，单元格 M58 = 4/50。 下一页应该是 5/50、6/50、7/50、8/50 等。

这是我用来每页只打印一个 label 并递增一个单元格值的代码：

Sub IncrementPrint()
'updateby Extendoffice
    Dim xCount As Variant
    Dim xScreen As Boolean
    Dim I As Long
    On Error Resume Next
LInput:
    xCount = Application.InputBox("Please enter the number of copies you want to print:", "Kutools for Excel")
    If TypeName(xCount) = "Boolean" Then Exit Sub
    If (xCount = "") Or (Not IsNumeric(xCount)) Or (xCount < 1) Then
        MsgBox "error entered, please enter again", vbInformation, "Kutools for Excel"
        GoTo LInput
    Else
        xScreen = Application.ScreenUpdating
        Application.ScreenUpdating = False
        For I = 1 To xCount
            ActiveSheet.Range("C27").Value = I & " / " & xCount
            ActiveSheet.PrintOut
        Next
        ActiveSheet.Range("C27").ClearContents
        Application.ScreenUpdating = xScreen
    End If
End Sub

Answer 1

以增量方式打印单个工作表的副本

Option Explicit

Sub PrintWithIncrement()
         
    Const WORKSHEET_NAME As String = "Sheet1"
    Const RANGE_ADDRESS As String = "C27,M27,C58,M58"
    Const PROMPT As String = "Please enter the number of copies you want to print:"
    Const TITLE As String = "Print With Increment"
    Const DEFAULT_COPIES As Long = 1
    Const MAX_COPIES As Long = 100
    Const APPLY_TOTAL_LOGIC As Boolean = False
    
    Dim pCount As Variant
    Dim Msg As Long
    Dim IsInputValid As Boolean

    Do Until IsInputValid
        pCount = Application.InputBox(PROMPT, TITLE, DEFAULT_COPIES, , , , , 1)
        If VarType(pCount) = vbBoolean Then
            MsgBox "Dialog canceled.", vbExclamation, TITLE
            Exit Sub
        End If
        If Int(pCount) = pCount Then
            If pCount > 0 Then IsInputValid = True
        End If
        If IsInputValid Then
            If pCount > MAX_COPIES Then
                Msg = MsgBox("This will print " & pCount & " copies." _
                    & vbLf & vbLf & "Are you sure?", _
                    vbQuestion + vbYesNo + vbDefaultButton2, TITLE)
                If vbNo Then IsInputValid = False
            End If
        Else
            MsgBox "lnvalid entry: " & pCount & vbLf & vbLf _
                & "Try again.", vbExclamation, TITLE
        End If
    Loop
        
    Application.ScreenUpdating = False
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Sheets(WORKSHEET_NAME)
    Dim rg As Range: Set rg = ws.Range(RANGE_ADDRESS)
    rg.NumberFormat = "@"
    Dim tCount As Long: tCount = pCount
    
    If APPLY_TOTAL_LOGIC Then tCount = tCount * rg.Cells.Count
    
    Dim cell As Range, p As Long, t As Long
    
    For p = 1 To pCount
        For Each cell In rg.Cells
            t = t + 1
            cell.Value = t & "/" & tCount
            Debug.Print cell.Value ' Test with this first! Uncomment later!
            'ws.PrintOut ' Out-comment when done testing!
        Next cell
    Next p

    rg.ClearContents
    
    Application.ScreenUpdating = True

    MsgBox "Print job finished.", vbInformation, TITLE

End Sub

我的 3 份逻辑 ( APPLY_TOTAL_LOGIC = TRUE )

1/12
2/12
3/12
4/12
5/12
6/12
7/12
8/12
9/12
10/12
11/12
12/12

3 份副本的逻辑 ( APPLY_TOTAL_LOGIC = FALSE )

1/3
2/3
3/3
4/3
5/3
6/3
7/3
8/3
9/3
10/3
11/3
12/3

Answer 2

这很容易通过一个循环和一个变量为您想要打印的 4 个单元格中的每一个来完成。 每次迭代后，变量值都会增加 4。

例如声明你的变量

dim cell_m27 as integer 

在循环之前将值设置为 1

cell_m27 = 1

在你的循环中，你每次增加一个：

cell_m27 = cell_m27 + 4

并复制其他三个变量，但从 2、3 和 4 开始。然后它们将在每个循环中增加 4，直到达到 xCount 并完成循环。

Answer 3

Sub IncrementPrint()

    Dim xCount As Variant, xScreen As Boolean, i As Long
    Dim rng As Range, bOK As Boolean, msg as string
    
    msg = "Please enter the number of copies you want to print:"
    Set rng = Range("C27,M27,C58,M58")
    rng.ClearContents
    rng.NumberFormat = "@"
    
LInput:

    xCount = Application.InputBox(msg)
    If TypeName(xCount) = "Boolean" Then Exit Sub

    bOK = False
    If IsNumeric(xCount) Then
        bOK = xCount > 0
    End If
    
    If bOK Then
        
        xScreen = Application.ScreenUpdating
        Application.ScreenUpdating = False
        i = 0
        Do While i <= xCount
            For Each c In rng.Cells
                i = i + 1
                If i <= xCount Then
                    c.Value = i & "/" & xCount
                End If
            Next
            ActiveSheet.PrintOut
            rng.ClearContents
        Loop        
        Application.ScreenUpdating = xScreen

    Else
        MsgBox xCount & " not numeric,please enter again", vbInformation
        GoTo LInput
    End If
End Sub