Dividing the Items of an Array over multiple Columns

**Jonathan78** · 05-10-2016, 07:40 AM

Hi all,

IMG1.jpg

I'm trying to divide the items of an array over 3 columns
Like in the image above.

I've tried the following but without succes


Ar3 = Worksheets("DBS").Range("J2:AD2")

    j = 1
    For i = 1 To UBound(Ar3)
        If j = 3 Then j = 1
            Worksheets("RSTR").Cells(77 + i, 4 + j).Value = Ar3(i, 1)
        j = j + 1
    Next i

**Doc.AElstein** · 05-10-2016, 09:46 AM

Hi again Jonathan78

Using exactly the ideas ( and a lot of the code ! ) that I showed you here yesterday:

http://www.excelforum.com/showthread...t=#post4381996

This code is much simpler version of that. .....!....

Sub JonAgain()    '    http://www.excelforum.com/excel-programming-vba-macros/1138627-dividing-the-items-of-an-array-over-multiple-columns.html
' Worksheets info.
Dim ws As Worksheet '                                                                                                        ' Preparing a "Pointer" to an Initial "Blue Print" in Memory of the Object ( Pigeon Hole with a bit of paper or code lines on that can be filled in to refer to a specific Objec of this type ) . This also us to get easily at the Methods and Properties throught the applying of a period ( .Dot) ( intellisense )
Set ws = ThisWorkbook.Worksheets("pgcArraysSplitToColumn")                        '( For Code in This Workbook  )             ''  Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer""
Set ws = Worksheets("pgcArraysSplitToColumn") 'CHANGE TO SUIT YOUR SHEET        (Refers here through Worksheets collection of open files  )
' Determine Last Column Number( Two typical methods ) and the last Row.  '                                                   ' http://www.mrexcel.com/forum/excel-questions/48638-macro-needs-select-last-column.html#post223306      http://www.mrexcel.com/forum/excel-questions/48638-macro-needs-select-last-column.html
Dim lc As Long '                                                '                                                            '  Long is very simple to handle, - final memory "size" type is known (123.456 and 000.001 have same "size" computer memory ) , and so a Address suggestion can be given for the next line when the variable is filled in.  '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster. )
Let lc = ws.Cells.Find(What:="*", After:=ws.Cells(1, 1), SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column       'The Find Method looks for anything, searching by columns, starting at the first Cell and going backwards, which effectivelly starts at the last column which allows for different XL versions. This will determine the column that has anything in any row rather than looking in a particular row as in the above line.
Let lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column '                                                             ' The Range Object ( cell ) that is the last cell in the row ( 1 here ) of interest, ( Column Number given by .Count Property applied to ( ws here, any would do, so wc can be ommited and the default for the macro is will be used ) Spreadsheet Range Columns Property)    has the Property .End ( argument "Looking to left" ) appled to it. This Returns a new Range ( cell ) object which is that of the first Range ( cell ) with something in it "looking back to the left" in the XL spreadsheet from that last cell. Then the .Column Property is applied to return a long number equal to the Column number of that cell
Let lc = 9 'Hard copy alternative if you know it
Dim arrIn() As Variant 'We use the .Value Property below which when returne to a range bigger than 1 cell returns an Field of Variant Element Types, so we must Dimension approriately. Also the Array must be dynamic to allow that assignment
Let arrIn() = ws.Range("A1", ws.Cells(1, lc)).Value 'Note This becomes 1 2 D 1 column Array
'ws.Columns(50).ClearContents ' Remove any data already there, Just to be sure the next lines do any thing
'The width you want of the Output Array
Dim Widf As Long: Let Widf = 3
' Hard copied Indicies for Output Array
Dim rws() As Variant, clms() As Variant 'Variant Elements chosen for these Arrays to match type of Elements returned by the methods we use below
Let rws() = Array(1, 1, 1, 2, 2, 2, 3, 3, 3) 'Note this is 0 - 8 base 0
Let clms() = Array(1, 2, 3, 1, 2, 3, 1, 2, 3)
' Some maths to get a more flexible solution
    '    Let rws() = Evaluate("int((column(A:I)+(3-1))/3))") ' The Maths is sound here, but you will only get the first value out of an internally made Array
    '    Let clms() = Evaluate("mod((column(A:I)-1),3))+1") ' You need to do a trick which stretches VBA to give out in your "Area" which would enclose all the values VBA has to offer           http://www.mrexcel.com/forum/excel-questions/806702-visual-basic-applications-evaluate-range-vlookup.html?#post3944034
Let rws() = Evaluate("if(column(A:I),int((column(A:I)+(3-1))/3))") ' if(column(A:I),_______) is one.....
Let clms() = Evaluate("If(column(A:I),(mod((column(A:I)-1),3))+1)") '..... Trick to return an Array of all VBA has to offer for us in this case
'Making those more flexible:
Dim strlClm As String 'Last column as Letter
Let strlClm = shgMathsVBASHimpfGlified(lc)
Let rws() = Evaluate("if(column(A:" & strlClm & "),int((column(A:" & strlClm & ")+(" & Widf & "-1))/" & Widf & "))")
Let clms() = Evaluate("If(column(A:" & strlClm & "),(mod((column(A:" & strlClm & ")-1)," & Widf & "))+1)") 'Note these are 1 - 9 base 1
'Make output Array using those Indicies
Dim arrout() As String 'We filll by looping and know type so can Dimension appropriately. We also know the size, so a Static 8 fixed size ) Array would be OK, but Dim only takes actual numbers, so we use below the ReDim which allows variables to be used
ReDim arrout(1 To (lc / Widf), 1 To Widf) 'make Approprately sized Array
Dim Cnt As Long 'Loop Bound Variable Count
    For Cnt = 1 To lc 'Doing for all Input and output values
    arrout(rws(Cnt), clms(Cnt)) = arrIn(1, Cnt) 'Go along each indice pair and put in the next Input Array value
    Next Cnt
'Now paste Out to any Range starting at Top Left of
Dim TL As Range: Set TL = ws.Range("A40")
                            TL.Resize(UBound(arrout(), 1), UBound(arrout(), 2)).ClearContents 'Just to make sure the next line does something!
Let TL.Resize(UBound(arrout(), 1), UBound(arrout(), 2)).Value = arrout() ' Neat simple way to paste out the Values of an Array to a spreadsheet. The Top Left cell of where the Output should go has the .Resize Property applied whichreturns a new range Object of increased size. In this case we increase the dimension to the dimensions of the Output Array. Then the Allowed VBA one liner assighnment is used to assign the values of an Array to a Spreadsheet Range
End Sub
Public Function shgMathsVBASHimpfGlified(ByVal lClm As Long) As String '   http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html#post4221359
Let shgMathsVBASHimpfGlified = IIf(((((lClm - 1) \ 26) - 1) \ 26), Chr(65 + (((((lClm - 1) \ 26) - 1) \ 26) - 1 Mod 26)), "") & IIf(((lClm - 1) \ 26), Chr(65 + (((lClm - 1) \ 26) - 1) Mod 26), "") & IIf(lClm, Chr(65 + (lClm - 1) Mod 26), "")
End Function

It will take for example this

Using Excel 2007

_Row\^Col	A	B	C	D	E	F	G	H	I	J
1	1	Area 1	Area 59	6	1	1	any	3	Finks

pgcArraysSplitToColumn

And it will give you this

_Row\^Col	A	B	C
40	1	Area 1	Area 59
41	6	1	1
42	any	3	Finks

And here a simplified code version ( Note to run it you still need the Function shgMathsVBASHimpfGlified copied to the same module as the Main code )

Sub JonAgainSHimpfGlified()
Dim arrIn() As Variant: arrIn() = Range("A1:I1").Value
Dim Widf As Long, lc As Long: Widf = 3: lc = 9
Dim arrout() As Variant
ReDim arrout(1 To (lc / Widf), 1 To Widf)
Dim Cnt As Long
    For Cnt = 1 To lc
    arrout(Evaluate("if(column(A:" & shgMathsVBASHimpfGlified(lc) & "),int((column(A:" & shgMathsVBASHimpfGlified(lc) & ")+(" & Widf & "-1))/" & Widf & "))")(Cnt), Evaluate("If(column(A:" & shgMathsVBASHimpfGlified(lc) & "),(mod((column(A:" & shgMathsVBASHimpfGlified(lc) & ")-1)," & Widf & "))+1)")(Cnt)) = arrIn(1, Cnt)
    Next Cnt
                                          Range("A40").Resize(UBound(arrout(), 1), UBound(arrout(), 2)).ClearContents
Let Range("A40").Resize(UBound(arrout(), 1), UBound(arrout(), 2)).Value = arrout()
End Sub

Alan

Jack ....done it nice ??

**Jonathan78** · 05-10-2016, 09:59 AM

Thanks Doc.AElstein, but I go for the shorter solution

**Bernie Deitrick** · 05-10-2016, 09:53 AM

Sub TestMacro()
    Dim Ar3 As Variant
    Dim i As Integer
    
    Ar3 = Worksheets("DBS").Range("J2:AD2")

    For i = 1 To UBound(Ar3, 2)
        Worksheets("RSTR").Cells(77 + Int((i - 1) / 3), 4 + ((i - 1) Mod 3)).Value = Ar3(1, i)
    Next i
End Sub

**Jonathan78** · 05-10-2016, 09:58 AM

Exactly what I was looking for, Thanks Bernie!

**Kenneth Hobson** · 05-10-2016, 10:41 AM

Since I finished this after the other posts, here it is for what it is worth.

Keep in mind that simple or short solutions are not always optimized for speed. Settings like ScreenUpdating, Calculation, Events, and such can be used to help with speed issues. My Speedup routines: http://vbaexpress.com/kb/getarticle.php?kb_id=1035

I find that writing to an array and then writing to a range all at once is faster than one cell at a time. For your scenario, speed should not be a significant issue.

Sub Main()
  Dim a() As Variant, b() As Variant
  a() = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Worksheets("DBS").Range("J2:AD2").Value))
  'MsgBox Join(a(), vbLf)
  b() = vA1dto2d(a(), 1, 3, 1, WorksheetFunction.RoundUp((UBound(a) + 1) / 3, 0)) 'Roundup as fractions not allowed.
  'Show2DArray b()
  Worksheets("RSTR").Range("E78").Resize(UBound(b, 2), UBound(b, 1)).Value = WorksheetFunction.Transpose(b)
End Sub


Sub Test_vA1dto2d()
  Dim a() As Variant, b() As Variant
  a() = Array(1, 2, 3, 4, 5, 6, 7)
  Debug.Print LBound(a), UBound(a), (UBound(a) + 1) / 3
  MsgBox Join(a, vbLf)
  b() = vA1dto2d(a(), 1, 3, 1, WorksheetFunction.RoundUp((UBound(a) + 1) / 3, 0)) 'Roundup as fractions not allowed.
  Show2DArray b()
End Sub


Function vA1dto2d(a1d() As Variant, dimColl As Long, dimColU As Long, _
  dimRowl As Long, dimRowU As Long) As Variant
  Dim i As Long, j As Long, z As Long, a() As Variant
  
  On Error Resume Next
  z = LBound(a1d)
  ReDim a(dimColl To dimColU, dimRowl To dimRowU)
  For j = dimRowl To dimRowU
    For i = dimColl To dimColU
      a(i, j) = a1d(z)
      z = z + 1
    Next i
  Next j
  
  vA1dto2d = a()
End Function

'similar to, http://www.cpearson.com/excel/vbaarrays.htmhttp://www.cpearson.com/excel/vbaarrays.htm
Public Sub Show2DArray(ByRef myArry() As Variant)  '<-- Note ByRef modifier.
  Dim x As Long
  Dim y As Long
  Dim s As String

  s = ""
  For y = LBound(myArry, 2) To UBound(myArry, 2)
    For x = LBound(myArry, 1) To UBound(myArry, 1)
      s = s & myArry(x, y) & ", "
    Next x
    If Mid(s, Len(s) - 1, 1) = "," Then s = Left(s, Len(s) - 2)
    s = s & vbNewLine
  Next y
  MsgBox s
End Sub

**Doc.AElstein** · 05-10-2016, 12:49 PM

Thanks Kenneth Hobson and Bernie Deitrick for adding here

Alan

_..

And here just a couple of versions of my code that do not need the Column Letter Function ( Function to get the Column Letter from Column Number )

The original Function is simply included in the main code line in the first code.

Sub JonAgainSHimpfGlified2() ' Version Ohne main Column Letter Function ( Function Combined )
Dim arrIn() As Variant: arrIn() = Range("A1:I1").Value
Dim Widf As Long, lClm  As Long: Widf = 3: lClm = 9
Dim arrout() As Variant
ReDim arrout(1 To (lClm / Widf), 1 To Widf)
Dim Cnt As Long
    For Cnt = 1 To lClm
    arrout(Evaluate("if(column(A:" & IIf(((((lClm - 1) \ 26) - 1) \ 26), Chr(65 + (((((lClm - 1) \ 26) - 1) \ 26) - 1 Mod 26)), "") & IIf(((lClm - 1) \ 26), Chr(65 + (((lClm - 1) \ 26) - 1) Mod 26), "") & IIf(lClm, Chr(65 + (lClm - 1) Mod 26), "") & "),int((column(A:" & IIf(((((lClm - 1) \ 26) - 1) \ 26), Chr(65 + (((((lClm - 1) \ 26) - 1) \ 26) - 1 Mod 26)), "") & IIf(((lClm - 1) \ 26), Chr(65 + (((lClm - 1) \ 26) - 1) Mod 26), "") & IIf(lClm, Chr(65 + (lClm - 1) Mod 26), "") & ")+(" & Widf & "-1))/" & Widf & "))")(Cnt), _
           Evaluate("If(column(A:" & IIf(((((lClm - 1) \ 26) - 1) \ 26), Chr(65 + (((((lClm - 1) \ 26) - 1) \ 26) - 1 Mod 26)), "") & IIf(((lClm - 1) \ 26), Chr(65 + (((lClm - 1) \ 26) - 1) Mod 26), "") & IIf(lClm, Chr(65 + (lClm - 1) Mod 26), "") & "),(mod((column(A:" & IIf(((((lClm - 1) \ 26) - 1) \ 26), Chr(65 + (((((lClm - 1) \ 26) - 1) \ 26) - 1 Mod 26)), "") & IIf(((lClm - 1) \ 26), Chr(65 + (((lClm - 1) \ 26) - 1) Mod 26), "") & IIf(lClm, Chr(65 + (lClm - 1) Mod 26), "") & ")-1)," & Widf & "))+1)")(Cnt)) _
           = arrIn(1, Cnt)
    Next Cnt
                                          Range("A40").Resize(UBound(arrout(), 1), UBound(arrout(), 2)).ClearContents
Let Range("A40").Resize(UBound(arrout(), 1), UBound(arrout(), 2)).Value = arrout()
End Sub

_................................

For the second a simple Function to get the Column Letter from Column Number is incorporated into the main Code

Sub JonAgainSHimpfGlified3()  ' Version with simpler Letter Column Funktion    http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html      http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213969
Dim arrIn() As Variant: arrIn() = Range("A1:I1").Value
Dim Widf As Long, lClm  As Long: Widf = 3: lClm = 9
Dim arrout() As Variant
ReDim arrout(1 To (lClm / Widf), 1 To Widf)
Dim Cnt As Long
    For Cnt = 1 To lClm
    arrout(Evaluate("if(column(A:" & Split(Cells(1, lClm).Address, "$")(1) & "),int((column(A:" & Split(Cells(1, lClm).Address, "$")(1) & ")+(" & Widf & "-1))/" & Widf & "))")(Cnt), Evaluate("If(column(A:" & Split(Cells(1, lClm).Address, "$")(1) & "),(mod((column(A:" & Split(Cells(1, lClm).Address, "$")(1) & ")-1)," & Widf & "))+1)")(Cnt)) = arrIn(1, Cnt)
    Next Cnt
                                          Range("A40").Resize(UBound(arrout(), 1), UBound(arrout(), 2)).ClearContents
Let Range("A40").Resize(UBound(arrout(), 1), UBound(arrout(), 2)).Value = arrout()
End Sub

As before for thes examples, this is the Input Range.
Using Excel 2007

_Row\^Col	A	B	C	D	E	F	G	H	I	J
1	1	Area 1	Area 59	6	1	1	any	3	Finks

Output is
Using Excel 2007

_Row\^Col	A	B	C
40	1	Area 1	Area 59
41	6	1	1
42	any	3	Finks

_..........................................................

So Last column is ( lClm ) is 9
Wanted Width ( Widf ) is 3
Wanted Top left is A40

Dividing the Items of an Array over multiple Columns

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Dividing the Items of an Array over multiple Columns

Re: Dividing the Items of an Array over multiple Columns

Re: Dividing the Items of an Array over multiple Columns

Re: Dividing the Items of an Array over multiple Columns

Re: Dividing the Items of an Array over multiple Columns

Re: Dividing the Items of an Array over multiple Columns

Re: Dividing the Items of an Array over multiple Columns

Thread Information

Users Browsing this Thread

Similar Threads

Array formula to return list of unique items from selected columns only

Summing items in multiple columns

[SOLVED] [SOLVED] Array formula to sum items that meet multiple conditions

[SOLVED] Count several items in multiple columns

[SOLVED] Using Index and Match to search an array that has multiple items in each cell

[SOLVED] Excel 2007 : Trying to match like items in multiple columns

Select multiple listbox items and pass to an array

Bookmarks

Bookmarks

Posting Permissions