Populate data in columns by selction

[YasserKhalil]

Hello everyone
I have two sheets .. In sheet 1 I will select two cells that have range of numbers
for example
in E2 and F2 I have 1 - 244 and 1377 - 1620
In Result sheet I want to populate those numbers in specific way .. each 40 numbers in single column and the next 40 in adjacent column and the next 40 in adjacent column
After that move to another page in the same way

I have attached the expected result so as to make it clear.. I don't know but I feel it is complicated to do such a thing
But I hope to find a solution as this will save me hours

[HansV]

Why do does the second block (rows 43 - 81) contain only 39 numbers? If you really want that, I don't understand the requirements. If it was a mistake, here is a macro:

Code: Select all

Sub FillResults()
    Dim wshS As Worksheet
    Dim wshR As Worksheet
    Dim i    As Long
    Dim arr  As Variant
    Dim lb   As Long
    Dim ub   As Long
    Dim j    As Long
    Dim r    As Long
    Dim c    As Long
    Application.ScreenUpdating = False
    Set wshS = Worksheets("Sheet1")
    Set wshR = Worksheets("Result")
    wshR.Cells.Clear
    For i = 1 To 2
        r = 1
        c = i
        arr = Split(wshS.Range("E2").Offset(0, i - 1).Value, " - ")
        lb = arr(0)
        ub = arr(1)
        For j = lb To ub
            If (j - lb) Mod 120 = 0 Then
                c = i
                wshR.Cells(r, c).Value = "S" & i
                r = r + 1
            ElseIf (j - lb) Mod 40 = 0 Then
                r = r - 41
                c = c + 3
                wshR.Cells(r, c).Value = "S" & i
                r = r + 1
            End If
            wshR.Cells(r, c).Value = j
            r = r + 1
        Next j
    Next i
    For c = 1 To 7 Step 3
        With wshR.Cells(1, c).CurrentRegion
            .HorizontalAlignment = xlHAlignCenter
            .Borders.LineStyle = xlContinuous
        End With
    Next c
    Application.ScreenUpdating = True
End Sub

[YasserKhalil]

That's amazing Mr. Hans
I really thank you for this perfect solution

Just point as for the headers S1 and S2 are not dynamic (they are fixed headers)
If possible can it be flexible as I need to determine the number of numbers (I have tried to change 40 to 30 ..and I see 120 and changed to 90 but got error)
And I can't see page breaks in the code ..or I missed that

[HansV]

To set the page breaks, change the inner loop to

Code: Select all

        For j = lb To ub
            If (j - lb) Mod 120 = 0 Then
                c = i
                wshR.Cells(r, c).Value = "S" & i
                ' *** New code ***
                If r > 1 Then
                    wshR.HPageBreaks.Add wshR.Cells(r, c)
                End If
                ' *** End of new code ***
                r = r + 1
            ElseIf (j - lb) Mod 40 = 0 Then
                r = r - 41
                c = c + 3
                wshR.Cells(r, c).Value = "S" & i
                r = r + 1
            End If
            wshR.Cells(r, c).Value = j
            r = r + 1
        Next j

I don't understand your remark about the headers.

[YasserKhalil]

As for headers I mean the headers are fixed not dynamic as I can see "S" & i ..
Last point .. what if I need to change 40 to any other number ..? will I change 40 and 120 only?

[Doc.AElstein]

Hi Yasser , ………………………………………………………….. سنه جديده سعيده
Happy New Year Hans..

I started doing a Function, so I finished it……

It will take numbers like 1, 244, 1377, 1620 and then give your wanted result (I think, like Hans said, your test data is a bit wrong – check your row 82 should be 83 I think )
The function is hard coded inside for 40 data rows, and 3 columns of Result data, but you could easily adapt that for different numbers
Rem 1 gives the entire 2 columns of results , similar to in some of your last Threads. Full data arrays ( 2 of them ) are got here for the ranges, ( in your example 1 - 244 and 1377 – 1620 )

Rem 2 does some simple maths to get the number of final sections, ( 7 in your example )

Rem 3 does some not so simple maths to get
row and column, Top left indices,
rTL and cTL , of where the output should go. You want
rows and columns of
1,1,1,42,42,42,83 and 1,4,7,1,4,7,1

Rem 4 Uses Index( arrIn() , {1,2,3,4 } , 0 ) type stuff that you know about for pulling out part of an array to get the data section columns of data

Rem 5 Pastes out to the worksheet

Alan

Code: http://www.excelfox.com/forum/showthrea ... #post10881
https://tinyurl.com/yd95w5v2" onclick="window.open(this.href);return false;

Code: Select all

Sub SpltTests()
 Call Splt(1, 244, 1377, 1620)
End Sub
Function Splt(ByVal N1a As Long, ByVal N1b As Long, ByVal N2a As Long, ByVal N2b As Long) As Variant ' Variant as I don't know yet what might be wanted as output
Rem 1 full columns of data - full data arrays
Dim Clm1() As Variant: Let Clm1() = Evaluate("=row(" & N1a & ":" & N1b & ")")  ' This returns a one "column" 2 Dimensional array of all the numbers between N a and N b
Dim Clm2() As Variant: Let Clm2() = Evaluate("=row(" & N2a & ":" & N2b & ")")
Rem 2 get total number of arrays needed
Dim En As Long ' We want
 Let En = Int(((N1b - N1a) + 1) / 40) + 1
Rem 3a Not so simple maths to get some grouped numbers for top left of output arrays
' I need rows 1,1,1,42,42,42,83, columns 1,4,7,1,4,7,1
Dim ltrEn As String: Let ltrEn = Cltr(En) ' column letter from column number - G in example data
Dim ltrEnPlus3 As String: Let ltrEnPlus3 = Cltr(En + 3)
Dim Rws() As Variant ' row co ordinates of outout arrays
 Let Rws() = Evaluate("=Index((int((column(D:" & ltrEnPlus3 & ")-1)/3)),)") ' Evaluate("=Index((int((column(D:J)-1)/3)),)") 'returns {1, 1, 1, 2, 2, 2, 3}
Dim Clms() As Variant ' column co ordinates of output arrays
 Let Clms() = Evaluate("=Index((mod(column(A:" & ltrEn & ")-1,3)+1),)") ' Evaluate("=Index((mod(column(A:G)-1,3)+1),)") 'Returns { 1, 2, 3, 1,  2, 3, 1 }
Dim Cnt '  Loop for all data sections ==================================================
    For Cnt = 1 To En
    Rem 3b Top left for each array
    Dim rTL As Long, cTL As Long
     Let rTL = ((Rws(Cnt) - 1) * 41) + 1 ' In the looping this will give 1,1,1,42,42,42,83
     Let cTL = ((Clms(Cnt) - 1) * 3) + 1 ' In the looping this will give 1,4,7,1,4,7,1
    Rem 4 Columns of data for each loop
    Dim ClmOut1() As Variant, ClmOut2() As Variant '4a) use Index with arrays to get part of the sections from full data arrays
     Let ClmOut1() = Application.Index(Clm1(), Evaluate("=column(" & Cltr(((Cnt - 1) * 40) + 1) & ":" & Cltr(Cnt * 40) & ")"), 0) ' column 1
     Let ClmOut2() = Application.Index(Clm2(), Evaluate("=column(" & Cltr(((Cnt - 1) * 40) + 1) & ":" & Cltr(Cnt * 40) & ")"), 0) ' column 2
    Dim ClmOut1_1(1 To 40, 1 To 1) As Variant, ClmOut2_1(1 To 40, 1 To 1) As Variant ' I need Variant so as to get empty back for last array in loop paste out
    Dim Cnt2 As Long '4b) Loop to get convenient for output   2 dimensional 1 column arrays
        For Cnt2 = 1 To 40
            If IsError(ClmOut1(Cnt2)) Then Exit For ' To stop filling last array for large than top range value
         Let ClmOut1_1(Cnt2, 1) = ClmOut1(Cnt2) ' column 1
         Let ClmOut2_1(Cnt2, 1) = ClmOut2(Cnt2) ' column 2
        Next Cnt2
    Rem 5 Output of arrays to worksheet
    '5a Title
    Dim Tital(1 To 1, 1 To 2) As String: Let Tital(1, 1) = "S1": Let Tital(1, 2) = "S2"
    '5b Columns of data
    Dim WsRes As Worksheet: Set WsRes = Worksheets("Result")
     WsRes.Cells.Item(rTL, cTL).Resize(1, 2).Value = Tital() ' Title
     WsRes.Cells.Item(rTL + 1, cTL).Resize(40, 1).Value = ClmOut1_1() ' column 1
     WsRes.Cells.Item(rTL + 1, cTL + 1).Resize(40, 1).Value = ClmOut2_1() 'column 2
     Erase ClmOut1_1(), ClmOut2_1() ' without doing this out last array will not have any empties in it
    Next Cnt ' =============================================================================
End Function

' Column letter  http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Function Cltr(ByVal lclm As Long) As String 'Using chr function and Do while loop      For example http://www.excelforum.com/excel-programming-vba-macros/796472-how-to-go-from-column-number-to-column-letter.html
    Do
     Let Cltr = Chr(65 + (((lclm - 1) Mod 26))) & Cltr
     Let lclm = (lclm - (1)) \ 26 'This gives the number of 26's ( if any ), but just the excact part, in the next number down , - so applying the rest formula to this new number will again leave a difference "left over" rest.
    Loop While lclm > 0 'Only loop further if number was big enough to still have 0-25's in it
End Function
'Dim arr1_40() As Variant: Let arr1_40() = Evaluate("=column(A:AN)") ' {1, 2, 3 ....40}

( Note: You need a second function to get the column letter from a column number, Function Cltr( ) . It is included in the code window above )

[HansV]

Here is a more generic version.

Code: Select all

Sub FillResults()
    Const blk = 40  ' Number of items per block
    Const grp = 3   ' Number of blocks to place next to each other
    Const off = 3   ' Offset of each group from the next
    Dim hdrs As Variant
    Dim wshS As Worksheet
    Dim wshR As Worksheet
    Dim i    As Long
    Dim arr  As Variant
    Dim lb   As Long
    Dim ub   As Long
    Dim j    As Long
    Dim r    As Long
    Dim c    As Long
    Application.ScreenUpdating = False
    hdrs = Array("S1", "S2")
    Set wshS = Worksheets("Sheet1")
    Set wshR = Worksheets("Result")
    wshR.Cells.Clear
    wshR.ResetAllPageBreaks
    For i = 1 To 2
        r = 1
        c = i
        arr = Split(wshS.Range("E2").Offset(0, i - 1).Value, " - ")
        lb = arr(0)
        ub = arr(1)
        For j = lb To ub
            If (j - lb) Mod blk * grp = 0 Then
                c = i
                wshR.Cells(r, c).Value = hdrs(i - 1)
                ' *** New code ***
                If r > 1 Then
                    wshR.HPageBreaks.Add wshR.Cells(r, c)
                End If
                ' *** End of new code ***
                r = r + 1
            ElseIf (j - lb) Mod blk = 0 Then
                r = r - blk - 1
                c = c + off
                wshR.Cells(r, c).Value = hdrs(i - 1)
                r = r + 1
            End If
            wshR.Cells(r, c).Value = j
            r = r + 1
        Next j
    Next i
    For c = 1 To off * grp Step off
        With wshR.Cells(1, c).CurrentRegion
            .HorizontalAlignment = xlHAlignCenter
            .Borders.LineStyle = xlContinuous
        End With
    Next c
    Application.ScreenUpdating = True
End Sub

If you want blocks of 30 numbers instead of 40, change blk from 40 to 30.
If you want to have 4 blocks next to each other instead of 3, change grp from 3 to 4.
If you want the blocks in columns A, F, K etc. instead of in columns A, D, G etc., change off from 3 to 5 (the distance from column A to column F is 5 columns).
If you want different headers than S1 and S2, change the array hdrs.

[YasserKhalil]

Thank you very much Mr. Alan and Mr. Hans for perfect solutions
I would take the generic solution as I will need to change the blocks and sometimes the group of columns too
Thank you very much for awesome help

Have a nice time all the time excel masters