Excel VBA Auto increment cell value after each printing

0 votes

On EctendOffice, I discovered a VBA method to increase a cell number after printing. After each printing, I now need to increase the values of 4 cells on the same page. For instance, when I set the number of printings to 50, Cell C27, Cell M27, Cell C58, and Cell M58 should each have a value of 1/50, 2/50, 3/50, and 4/50. as well as 5/50, 6/50, 7/50, 8/50, etc. on the following page.

This is the code I used to increment one cell value and print just one label on every page:

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
Jan 22 in Others by Kithuzzz
• 38,010 points
745 views

1 answer to this question.

0 votes

Print Copies of Single Worksheet With Increment

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

My Logic for 3 Copies (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

Your Logic For 3 Copies (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
answered Jan 22 by narikkadan
• 63,160 points

Related Questions In Others

0 votes
1 answer

EXCEL: Auto number rows until value in cell

You can utilize SEQUENCE if you have ...READ MORE

answered Jan 20 in Others by narikkadan
• 63,160 points
172 views
0 votes
1 answer

VBA Excel: Draw line between cells based on cell value

In accordance with your description and with ...READ MORE

answered Feb 6 in Others by narikkadan
• 63,160 points
462 views
0 votes
1 answer

Create a hyperlink to a sheet with same name as the value in the selected cell in Excel through VBA

Credit to Spectral Instance who found the ...READ MORE

answered Feb 6 in Others by narikkadan
• 63,160 points
269 views
0 votes
1 answer

Excel-VBA - How to identify Target range (more than 1 cell) is deleted in a Worksheet_Change function?

You misunderstand the purpose of the function ...READ MORE

answered Sep 23, 2022 in Others by narikkadan
• 63,160 points
2,586 views
0 votes
1 answer

Retrieve epay.info Balance with VBA and Excel

This code should log you in, provided ...READ MORE

answered Sep 5, 2018 in Blockchain by digger
• 26,740 points
701 views
0 votes
1 answer

How to load file to Excel Power query from SFTP site

Currently, I don't think there is a ...READ MORE

answered Dec 3, 2018 in Power BI by Upasana
• 8,620 points
2,902 views
0 votes
1 answer

Using VBA Excel to create a gramatically correct list

The Excel AND function is a logical ...READ MORE

answered Feb 9, 2022 in Others by gaurav
• 23,220 points
235 views
0 votes
2 answers

How to copy a formula horizontally within a table using Excel VBA?

Hi so basically, create an adjacent column ...READ MORE

answered Feb 16, 2022 in Others by Edureka
• 13,670 points
549 views
0 votes
1 answer

How to increment the Range of a For Each loop - Excel VBA

Your formula seems to sum 1 single ...READ MORE

answered Jan 7 in Others by narikkadan
• 63,160 points
1,360 views
0 votes
1 answer

Highlighting Unique List of Words in Each Cell of a Selection of Cells - Excel VBA

In a Textbox it is a vbcrlf ...READ MORE

answered Jan 12 in Others by narikkadan
• 63,160 points
200 views
webinar REGISTER FOR FREE WEBINAR X
REGISTER NOW
webinar_success Thank you for registering Join Edureka Meetup community for 100+ Free Webinars each month JOIN MEETUP GROUP