• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

For print, distribute data base on number of columns

Marc L said:
So that simplifies a bit the code and it will be a mix of both ways for a better efficiency …​
It works according to the source data columns width, the paper size, margins and top header to repeat, …​
… so to be managed by an user.​
According to your 4 columns attachment, as it is the result is a 4 columns x 2 blocks.​
After operating a well fit page setup by reducing the margins to a reasonable one centimeter (0.4 inch) for example,​
the result should turn to a 4 columns x 3 depending on an empirical parameter, to be continued …​
If it works for your 4 columns workbook, it works too for your other 2 & 3 columns.​
(I'm still testing - when I have time - the workarounds between different computers screen setup, an Excel well known 'issue'.)​
​
Another question :​
where should be located the code : within the source data workbook (so to be saved as .xlsb / .xlsm) or explain the user context ?​
​
Click to expand...

Dear Sir @Marc L ,
I always store all success & invaluable (atleast for me) codes in personel.xlsb... many thanks for your precise effort..
Regards,
Chirag Raval
 
I had to restart back from automatizing what any Excel beginner user - even a child ! - can yet operate manually​
so now it's an empirical way still managing workarounds but more reliable than the previous try …​
​
As a starter, this demonstration copies the source sheet (aka Set Ws = Sheet1) to a new sheet 'Result'​
in order to keep the source columns block as it is, easier & safer for a testing purpose,​
then it fits the maximum blocks # according to the source page setup :​
Code: 
Sub DemoE1()
      Const S = "Result"
        Dim Ws As Worksheet, Rw As Range, C%, R&, P&, W(), L%, N%
        Set Ws = Sheet1
        Set Rw = Ws.[A1].CurrentRegion.Rows
        C = Rw.Columns.Count
         If Ws.UsedRange.Columns.Count > C Then Ws.Columns(C + 1).Resize(, Columns.Count - C).Delete
        R = Rw.Count
         If Ws.UsedRange.Rows.Count > R Then Ws.Rows(R + 1 & ":" & Rows.Count).Delete
    With Application
      .DisplayAlerts = False:  .ScreenUpdating = False
      .Goto Ws.[A50], True
        P = Ws.HPageBreaks(1).Location.Row
      .Goto [A1], True
    End With
    If P > R Then
            Ws.PrintPreview
    Else
            If Evaluate("ISREF('" & S & "'!A1)") Then Sheets(S).Delete
            Ws.Copy , Ws
            ActiveSheet.Name = S
            Set Rw = Range(Rw.Address).Rows
            ReDim W(C):  W(0) = 3:  For P = 1 To C:  W(P) = Cells(P).ColumnWidth:  Next
            Cells(Columns.Count) = " "
        Do
            Rw(1).Copy Cells(L + 1)
            L = L + C + 1
            N = N + 1
            Cells(L).Resize(, C + 1).ColumnWidth = W
        Loop While L + C < ActiveSheet.VPageBreaks(1).Location.Column
        If N > 1 Then
                 L = L - 1
            With [A1].Resize(, L).SpecialCells(xlCellTypeBlanks)
                     .ColumnWidth = Ws.StandardWidth
                While ActiveSheet.VPageBreaks(1).Location.Column <= L
                     .ColumnWidth = .ColumnWidth - 0.4
                Wend
            End With
                R = (R - 1) / N
                For P = 1 To N - 1:  Rw(2 + R * P).Resize(R).Cut Cells(2, 1 + (C + 1) * P):  Next
                Columns(Columns.Count).Delete
        Else
            Sheets(S).Delete:  Beep
        End If
    End If
        With Application:  .DisplayAlerts = True:  .ScreenUpdating = True:  End With
        Set Ws = Nothing:   Set Rw = Nothing
End Sub
Do you like it ? So thanks to click on bottom right Like !​
​
 
Managing page breaks is the main issue I met since last century whatever the Excel version and,​
like for pivot, the behavior changes from a version to another one, as often Excel is buggy, tricky, …​
​
The reason why I placed the Goto codeline just before …​
When the first row displayed is the #50, do you see under the horizontal page break in the same page screen ?​
Operate a print preview of the source data sheet before launching the demo in order to see the page breaks.​
​
BUT it seems you have amended the demonstration as 'application' does not appears in Proper style like within my code,​
or you have another procedure in the same module, an event firing, whatever …​
​
AS a reminder : Sheet1 is the source data sheet obviously in the workbook where is located the procedure​
so first for a testing purpose paste at least my demonstration as it is - no mod - in a standard module - like Module1 - of​
an original workbook from your attachment, but alone …​
​
 
Dear Sir @Marc L ,

Thanks, I already go to print preview & back to normal view to fall / flash /force to present page break objects on sheet..but , with just copy paste your code in personnel.xlsb (without any mod, just change Sub name) ...& i missed as per your instruction, now I should ,/.will run your code in original Workbook., in sheet1, .in single newly generated module, I will revert soon...Sir..

Regards,

Chirag Raval
 
You fell in the first trap as in your personal workbook Sheet1 is obviously not the Sheet1 codename of your initial attachment …​
​
 
Dear Sir @Marc L ,
Thanks for pin point that, now I will generate new file , data in sheet1 (codename of sheet, not sheet"s name which visible to user ) , copy your code in new module in that workbook , without any modification, , generate new sheet, name it "Result", copy data of sheet 1 to Result sheet & run your code. But..sorry, all can be happen Tomorrow, its now 11:55 pm at night in India, my body need sleep, & also all data & workbooks in my work office, i have no pc at home, i will be defiantly revert .till then many thanks your I invaluable efforts...

Regards,
Chirag Raval
 
No need to create the result worksheet as the procedure does it each time …​
​
See you, later …​
​
 
Dear Sir,

Amazing ...Just Run as Desired.... And perfectly page breaks on every 50 & in multiple rows, ...Great Sir,...Thank you..

But... work only in Unique workbook..that have only module1 ...can it run through personnel.xlsb? ...if that happen, Whole thread meet the solution...

Regards,

Chirag Raval
 
This first demonstration just reproduces what anyone can operate manually …​
​
To run it from your personal workbook just replace Sheet1 by a valid sheet reference​
like you used in other procedures of this personal workbook …​
​
 
What's up ?!​
​
Chirag R Raval said:
can we achieve more faster method?
Click to expand...
The Copy or Cut method is fast enough (instant with your attachment !)​
but in order to find out the optimal layout playing with columns width consumes time​
which can be easily bypass just warming a couple of neurons : just save the values for the next run !​
​
You may see it in a future demonstration but I wanna know on your computer what is the default column with ?​
As when I open your workbook on a computer the default column width is 8.43 and on another computer it is 8.11 for example …​
I yet know why but before shouting victory I need this information for a final tests bunch.​
​
 
It looks correct on my side and as you have the same default column width than one of my tests computer …​
​
The 'scientist' way just follows in fact a logic at child level : from the paper size minus the margins,​
how many rows and how many columns blocks can fit a print page​
which seems so easy with any smart application but Excel is not one of that kind !​
​
The first 'issue' is the paper size as Excel has no height & width for the page setup but just a code !​
For example for an A4 paper size the page setup code is 9 …​
Ok, according to this code it's not difficult to evaluate a width according to the page setup orientation.​
And for the usable width it just needs to substract the margins.​
​
But Excel does not work internally with centimeter or inch but use a pair of units !​
Points for the Width property and a 'character' unit for the ColumnWidth property, so weird ! …​
​
A partial reason comes from this observation under Windows : a worksheet has a 8.43 default column width on a computer​
but on another computer opening the same workbook the same worksheet has a 8.11 default column width !​
That comes from the Windows screen display setup, the dpi (dots per inches) in order Excel can handle pixels​
like when you manually enlarge a column you can see the Character width like 8.43 and the (pixels) …​
​
Excel has the necessary functions to convert a page width in Centimeters or Inches to Points.​
The centimeters converted to points have the same value on both computers but does not match​
the true usable width in the worksheet which is different between computers 'cause of the dpi setup :​
the reason why my first demonstration takes an empirical path to evaluate the usable width​
- the same way even an Excel beginner can operate manually - and​
approximates the blank column width which may not be optimal in some cases …​
​
So warming a couple of neurons, the idea is to apply a 'scientist' logic when possible​
and an empirical way only when there is no other choice : a mixed way to maximise the blank column width …​
And, as playing with column width consumes time during the execution​
the child logic says to save the results rather than calculating at each launch the same results, too obvious !​
​
So once the source page setup is fixed like the source columns range width, the first time the Mixed procedure​
is launched it will take time to evaluate the necessary values (usable width, columns blocks #, blank column width)​
but the next run, even if Excel was closed or the computer was rebooted, for the same source worksheet​
the execution needs less time (almost instant) as the necessary values are yet known and saved !​
Until the Windows screen display dpi, the paper size, the orientation, a margin or the source columns range width is changed …​
​
Once it's executed for a sheet like your 2 columns attachment, if you open on the same computer another workbook​
like for example the 3 columns the execution will be faster than the first launch as the usable width is yet saved,​
the procedure just needs to evaluate the columns blocks # and the blank column width.​
​
The Mixed procedure to see in next post …​
​
 
As the Mixed way below takes into account the page setup - paper size, orientation, margins - and the source columns range width​
it's better to optimize them before the first launch …​
​
As this way was started earlier than the previous demonstration,​
each Sheet1 statement refers to the CodeName of the source data worksheet,​
paste it to a standard module in the workbook of the source data worksheet for testing purpose and run it at least twice :​
Code: 
Sub DemoM1()
        Const S = "Result"
          Dim P%, C%, R&, V, U, Rw As Range, W(), N%
    With Application
            .DisplayAlerts = False:  .ScreenUpdating = False
            .Goto Sheet1.[A50], True
              P = Sheet1.HPageBreaks(1).Location.Row
            .Goto [A1], True
             With [A1].CurrentRegion:  C = .Columns.Count:  R = .Rows.Count:  End With
             V = .CentimetersToPoints(1) / 10
        If P > R Then
            Sheet1.PrintPreview
        Else
                 U = Cells(C + 2) = "###":  If U Then Columns(C + 2).Delete
                 If Evaluate("ISREF('" & S & "'!A1)") Then Sheets(S).Delete
                 Sheet1.Copy , Sheet1
                 Set Rw = [A1].CurrentRegion.Rows
            With Columns(C + 1).Resize(, Columns.Count - C)
                  If .Parent.UsedRange.Rows.Count > R Then Rows(R + 1 & ":" & Rows.Count).Delete
                     .Parent.Name = S
                With .Parent.PageSetup
                    V = Join(Array("Page", .PaperSize, .Orientation, Fix((.LeftMargin + .RightMargin) / V) / 10), "-")
                End With
                    V = Array(V, .Parent.StandardWidth, Rw.Width, "Usable Width")
                    If .Parent.UsedRange.Columns.Count > C Then .Delete Else .ColumnWidth = V(1)
            End With
                If U Then If Not IsEmpty(GetAllSettings(V(0), V(1))) Then DeleteSetting V(0), V(1)
                U = Split(GetSetting(V(0), V(1), V(2)))
                ReDim W(C)
            If UBound(U) = 1 Then
                W(0) = CDbl(U(0)):  N = U(1)
            Else
                    With Cells(Columns.Count):  .ColumnWidth = 3:  .Value2 = " ":  End With
                    U = GetSetting(V(0), V(1), V(3))
                    W(0) = 0
                If IsNumeric(U) Then
                    U = CDbl(U)
                Else
                    With Sheets(S).VPageBreaks(3).Location
                        Do
                             W(-(.Parent.VPageBreaks(3).Location.Column = .Column)) = .ColumnWidth
                            .ColumnWidth = Application.Average(W)
                        Loop Until .ColumnWidth - W(0) < 0.2
                             If .Parent.VPageBreaks(3).Location.Column = .Column Then .ColumnWidth = W(0)
                             U = Range(.Parent.VPageBreaks(2).Location, .Parent.VPageBreaks(3).Location(1, 0)).Width
                    End With
                        SaveSetting V(0), V(1), V(3), U
                End If
                     P = U \ V(2)
                     N = P + (U < V(2) * P + (P - 1) * Cells(Columns.Count).Width)
            End If
            If N > 1 Then
                If Not IsArray(U) Then
                         U = (U - V(2) * N) / (N - 1)
                    With Columns(Columns.Count)
                        Do
                            .ColumnWidth = U / .Width * .ColumnWidth
                        Loop While Abs(.Width - U) > 0.5
                             W(0) = .ColumnWidth
                            .Delete
                    End With
                End If
                    For P = 1 To C:  W(P) = Cells(P).ColumnWidth:  Next
                    R = (R - 1) / N
                For P = 1 To (N - 1)
                    With Cells((C + 1) * P).Resize(, C + 1)
                        .ColumnWidth = W
                         Rw(1).Copy .Cells(2)
                         Rw(2 + R * P).Resize(R).Cut .Cells(2, 2)
                    End With
                Next
            Else
                Sheets(S).Delete:  Beep
            End If
                If Not IsArray(U) Then SaveSetting V(0), V(1), V(2), W(0) & " " & N
                Set Rw = Nothing
        End If
             .DisplayAlerts = True:  .ScreenUpdating = True
    End With
End Sub
You may Like it !​
​
 
You must log in or register to reply here.
Back
Top