Code:
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}
_.__________________________
Reply With Quote
Bookmarks