Rearrange cells with VBA

skpma

New Member
Joined
Mar 3, 2020
Messages
29
Office Version
  1. 2016
  2. 2013
Platform
  1. Windows
Hello everyone

I have the following code (not written by me) and would like to add a new function.

VBA Code:
Private Const P_COL = 12   
Private Const P_ROW = 63   
Private Const VPAGE = 20   
Private Const W_COL = 1   
Private Const W_ROW = 631   
Private Const PICSCL = 0.99 


Type PrintCells
    sCol As Double 
    sRow As Double 
    eCol As Double 
    eRow As Double  
End Type

Private Function GetPageCells(ByVal wPage As Integer) As PrintCells
    Dim w1 As Integer
    Dim w2 As Integer
    If wPage Mod VPAGE = 0 Then
        w1 = Int(wPage / VPAGE) - 1
        w2 = VPAGE
    Else
        w1 = Int(wPage / VPAGE)
        w2 = wPage Mod VPAGE
    End If
    With GetPageCells
        .sRow = w1 * P_ROW + 1
        .eRow = (w1 + 1) * P_ROW
        .sCol = (w2 - 1) * P_COL + 1
        .eCol = w2 * P_COL
      End With
End Function

Public Sub InsertPage(ByVal wPage1 As Integer)

    Dim wp1 As PrintCells, wp2 As PrintCells  
    Dim wr As Integer
    Dim i As Long
    
  
    If wPage1 < 1 Then Exit Sub
    
    With ActiveSheet
   
        wp1 = GetPageCells(wPage1)
        
      
        .Range(.Cells(wp1.sRow, wp1.sCol), .Cells(wp1.eRow, wp1.eCol)).Insert Shift:=xlToRight
        .Range(.Cells(wp1.sRow, wp1.sCol), .Cells(wp1.eRow, wp1.eCol)).ClearFormats

   
        wr = (wPage1 - 1) \ VPAGE + 1
        Do Until wr > .HPageBreaks.Count
            wp2 = GetPageCells(wr * VPAGE)
            .Range(.Cells(wp2.sRow, wp2.sCol + P_COL), .Cells(wp2.eRow, wp2.eCol + P_COL)).Cut
            .Range(.Cells(wp2.sRow + P_ROW, 1), .Cells(wp2.eRow + P_ROW, P_COL)).Insert Shift:=xlToRight
            wr = wr + 1
            Application.CutCopyMode = False
        Loop
        DoEvents
    End With

End Sub

Public Sub DeletePage(ByVal wPage1 As Integer)

    Dim wp1 As PrintCells, wp2 As PrintCells   
    Dim wr As Integer
    Dim i As Long
    Dim shp As Shape
    Dim rng_shp As Range, rng_pg As Range
  

    If wPage1 < 1 Then Exit Sub
    
    With ActiveSheet
        
        wp1 = GetPageCells(wPage1)
        
    
        Set rng_pg = .Range(.Cells(wp1.sRow, wp1.sCol), .Cells(wp1.eRow, wp1.eCol))
        
 
        For Each shp In .Shapes
         
            Set rng_shp = .Range(shp.TopLeftCell, shp.BottomRightCell)
           
            If Not Intersect(rng_shp, rng_pg) Is Nothing Then
                shp.Delete
            End If
        Next
        
       
        rng_pg.Delete Shift:=xlToLeft
       
        wr = (wPage1 - 1) \ VPAGE + 1
        Do Until wr > .HPageBreaks.Count
            wp2 = GetPageCells(wr * VPAGE + 1)
            Call ChangePage(wr * VPAGE, wr * VPAGE + 1)
            .Range(.Cells(wp2.sRow, wp2.sCol), .Cells(wp2.eRow, wp2.eCol)).Delete Shift:=xlToLeft
            wr = wr + 1
            Application.CutCopyMode = False
        Loop
        DoEvents
    End With
    Set shp = Nothing
    Set rng_shp = Nothing
    Set rng_pg = Nothing

End Sub

With the above code, I can insert or delete a new page into/from the file. The already existing pages get moved forward (insertpage) or back (deletepage).
Currently after 20 of said pages, a new "row" starts, which means we always have 20 "pages" per row group (horizontally).

I want now to be able to set a new limit of pages and rearrange the cells accordingly.
For example in a user form, I choose to only have 10 pages per row group. The already existing pages (currently to page 20) should be arranged to only have 10 pages and the others get moved to the next row group below and so on.
How would I achieve that? The constants needs to be adjusted I think, but how to not loose any data? Would i put the cell data into an array?

Thanks in advance for your input.
 

Some videos you may like

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.

skpma

New Member
Joined
Mar 3, 2020
Messages
29
Office Version
  1. 2016
  2. 2013
Platform
  1. Windows
VBA Code:
Public Sub PageChange(ByVal wPage1 As Integer)
    Dim wp1 As PrintCells, wp2 As PrintCells
    Dim wr As Integer
    Dim i As Long

      VPAGE = wPage1
      With ActiveSheet

        wr = (wPage1 - 1) \ VPAGE + 1
        Do Until wr > .HPageBreaks.Count
      
            wp2 = GetPageCells(wr * VPAGE)
            .Range(.Cells(wp2.sRow, wp2.sCol + P_COL), .Cells(wp2.eRow, wp2.eCol + P_COL)).Cut
            .Range(.Cells(wp2.sRow + P_ROW, 1), .Cells(wp2.eRow + P_ROW, P_COL)).Insert Shift:=xlToRight
            wr = wr + 1
            Application.CutCopyMode = False
        Loop
        DoEvents
End With

End Sub

That's what I have so far, but the problem is it inserts a new empty page that I do not need.
It also works only for pages below the new page setting.
For example if I set the VPAGE setting to 5 then the code above works only until page 5 and then again on page 21 to 25 and so on.
Any suggestions?
 

skpma

New Member
Joined
Mar 3, 2020
Messages
29
Office Version
  1. 2016
  2. 2013
Platform
  1. Windows
Below is a simplified example to better illustrate what I want.
In the example I used 5 pages (current default is 20) as start and when I change the page setting to 3, it should move the pages according to the lower example.


Book1
ABCDEFGHIJ
1Pages setting 5
2
3Page1Page2Page3Page4Page5
4
5
6Page6Page7Page8Page9Page10
7
8
9Page11Page12Page13Page14Page15
10
11
12
13
14
15
16
17Pages after setting to 3
18
19Page1Page2Page3
20
21
22Page4Page5Page6
23
24
25Page7Page8Page9
26
27
28Page10Page11Page12
29
30
31Page13Page14Page15
32
Sheet1
 

skpma

New Member
Joined
Mar 3, 2020
Messages
29
Office Version
  1. 2016
  2. 2013
Platform
  1. Windows
How would I achieve what I described in my simplified example above? Maybe I can start from there with the more complex code...
 

skpma

New Member
Joined
Mar 3, 2020
Messages
29
Office Version
  1. 2016
  2. 2013
Platform
  1. Windows
No one any hint for me?
 

Watch MrExcel Video

Forum statistics

Threads
1,122,364
Messages
5,595,718
Members
414,013
Latest member
tnobbs

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top