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, 2023 in Others by Kithuzzz
• 38,000 points
1,393 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, 2023 by narikkadan
• 63,600 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, 2023 in Others by narikkadan
• 63,600 points
522 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, 2023 in Others by narikkadan
• 63,600 points
1,522 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, 2023 in Others by narikkadan
• 63,600 points
940 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,600 points
3,757 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
1,259 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
3,696 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,260 points
970 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,690 points
1,089 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, 2023 in Others by narikkadan
• 63,600 points
2,767 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, 2023 in Others by narikkadan
• 63,600 points
531 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