VBA code to make all worksheets evenly numbered

[Milos]

Hi all,

Can somebody please fix a problem that has ailed me for more than a year!? I need a code designed that will ensure that all worksheets in a workbook will have even page numbers...

With this I was thinking a VBA code that will read the content of each worksheet and assign a page number to each page. If the last page number in any worksheet equated to an even page (e.g. 2, 4, 6, 8, 10 pages etc.) then nothing;

But if the last page number in any worksheet equated to an odd page (e.g. 1, 3, 5, 7, 9 pages etc.) then I would need the code to automatically go down to the next page in that particular worksheet and enter a random value like "make pages even".

Please comment if you know how to design any such VBA code because I am baffled.

Thanks people really appreciate the help,

Milos

 

[NoSparks]

Maybe something like this ?

Sub EvenPages()

Dim i As Integer, x As Integer, lr As Long
Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets
    x = ws.PageSetup.Pages.Count
    MsgBox x
    If x Mod 2 = 1 Then
        With ws
            lr = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
            Do Until x Mod 2 = 0
                i = i + 10
                .Cells(lr + i, 1).Value = "make pages even"
                x = ws.PageSetup.Pages.Count
            Loop
            .Range(.Cells(lr + 1, 1), .Cells(lr + i - 1, 1)).ClearContents
        End With
    End If
Next ws

End Sub

 

[Milos]

Thanks for the help NoSparks.

It has worked kind of... although this code seems to be making even pages, unevenly...

I performed a trial with 12 worksheets all only 1 page long (I just put my name "Milos" in cell A1 for all of the 12 worksheets and nothing else). The message box worked perfectly: 1,1,1,1,1,1,1,1,1,1,1,1 etc.
But when I went to check the pages for the "make pages even" message, the message was distributed unevenly in the worksheets: 2,2,2,2,4,4,4,4,4,6,6,6 etc. It seemed to keep building the message further and further away from my actual page with non-blanks cells. I was expecting all the pages to be 2,2,2,2,2,2,2,2,2,2,2,2,2 etc.

How should I amend this code? I need the macro search for the last row (e.g. column A) with non-blank cells in each worksheet and then if the count is an odd number to go directly down to the next page and enter the message?

Thanks again,

 

[Fazza]

how is this, Milo?

Sub even_pages()


  Const sFiller As String = "make pages even"


  Dim i As Long
  Dim lRow As Long
  Dim wks As Excel.Worksheet


  For Each wks In Worksheets
    
    wks.Activate
    wks.ResetAllPageBreaks
    
    lRow = wks.UsedRange.Rows.Count
   
    i = 1
    wks.UsedRange.Select
    If ExecuteExcel4Macro("GET.DOCUMENT(50)") Mod 2 = 1 Then
      wks.Cells(lRow + i, 1).Value2 = sFiller
      Do Until ExecuteExcel4Macro("GET.DOCUMENT(50)") Mod 2 = 0
        wks.Cells(lRow + i, 1).ClearContents
        i = i + 1
        wks.Cells(lRow + i, 1).Value2 = sFiller
        wks.UsedRange.Select
      Loop
    End If
    
  Next wks
  Set wks = Nothing


End Sub

 

[Milos]

Awesome! It is currently passing my tests (fingers crossed; play it cool )!!!

Thanks for solving my year long riddle.

 

[Fazza]

Great to hear, Milos

I do wonder if it might be a little slow on large files.

All the best, Fazza

PS if it is slow, try adding a line near the beginning "application.screenupdating = false". i should have done that anyway and maybe a couple of others if you have other code or lots of calculations

 

[Milos]

Hey Frazza,

Almost… I am sorry to keep bugging you but I still need a little help here. I have only just gotten a chance to use this macro out with my actual data.

I used this macro to print off approximately 1000 pages (trying to save paper). I encountered a few issues but it still made my life far easier than before! I got several issues randomly halting my progress throughout including error 440 (automation error) and error 13 (mismatch error). What is clear is that the macro will only work for pages that are only 1 page long (which worked well as most of my pages are only 1 page long). I have performed several of tests and will described to you how the macro functioned:

Test 1 (on 7 worksheets): 6, 1, 7, 1, 1, 1 and 2 pages.
Test 1 with macro = 6, 2, 7, 2, 2, 2 and 2 pages.

Test 2 (on 8 worksheets): 1, 1, 2, 5, 5, 1, 3 and 4 pages.
Test 2 with macro = 2, 2, 2, 5, 5, 2, 3 and 4 pages.

Test 3 (on 20 worksheets): 10, 2, 1, 2, 4, 1, 1, 6, 3, 1, 4, 2, 4, 3, 1 and 12 pages.
Test 3 with macro: 10, 2, 2, 2, 4, 2, 2, 6, 3, 2, 4, 2, 4, 3, 2 and 12 pages.

Test 4 (on 1 worksheet): 4 pages.
Test 4 with macro = Run time error 13 mismatch error. I don't know what is different about this data

Test 5 (on 2 worksheets): 4 and 1 pages.
Test 5 with macro = Run time error 13 mismatch error.

What I need is a way to avoid the two errors and for the macro to work on all odd pages.

 

[Fazza]

hi Milos

please explain how you used/implemented the code

thanks

 

[NoSparks]

Maybe this will work, it just adds a page break then "make pages even" on next line

Sub EvenPages_try2()

Dim lr As Long, ws As Worksheet

Application.ScreenUpdating = False

For Each ws In ThisWorkbook.Worksheets
    With ws
        .Activate
        If .PageSetup.Pages.Count Mod 2 = 1 Then
            lr = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
            .HPageBreaks.Add Before:=Rows(lr + 1)
            .Cells(lr + 1, 1).Value = "make pages even"
        End If
    End With
Next ws

Application.ScreenUpdating = True

End Sub

 

[NoSparks]

Good, bad or indifferent, care to acknowledge the last suggestion ?