Macro Repeat and sort

[Dippy001]

Hi All

Hope your all doing well

I need some help with a macro please - I am trying to find a way where after every 4 columns the data is copied and all combined into one until there is no more data

Example

The Before

The After on a new sheet

Any help is much appreciated thank you

 

[kevin9999]

Try this

Sub Dippy001()
    Dim lc As Long, i As Long, j As Long
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Sheets("Sheet1")      '<~~ Change to actual sheet name
    Set ws2 = Sheets("Sheet2")      '<~~ Change to actual sheet name
    
    Application.ScreenUpdating = 0
    lc = ws1.Cells(1, Columns.Count).End(xlToLeft).Column - 3
    j = 1
    For i = 1 To lc Step 4
        ws1.Cells(1, i).Resize(10, 4).Copy ws2.Cells(j, 1)
        j = j + 10
    Next i
    Application.ScreenUpdating = 1
End Sub

 

[johnnyL]

I chose to take this opportunity to explore a different route to expand my knowledge of 3D arrays, and perhaps maybe the knowledge of some others.

The code allows for different amount of rows for each range. It may even run a bit faster than the code submitted by @kevin9999.

Sub Test_3DArray()
'
    Dim startTime                   As Single
'
    startTime = Timer                                                                                           ' Start the Stop watch
'
    Application.ScreenUpdating = False                                                                          ' Turn ScreenUpdating Off
''
    Dim ArrayColumnNumber           As Long, ArrayColumnNumberStart As Long, ColumnNumberOffset     As Long, LastColumnNumberInSheet    As Long
    Dim ArrayNumber                 As Long
    Dim ArrayRow                    As Long, DestinationArrayRow    As Long, LastRowInBlockRange    As Long, LastRowInSheet             As Long
    Dim LastRowInBlockRangeFinder   As Long, StartRowOfHeader       As Long
    Dim DataBlockSize               As Long, NumberOfDataBlocks     As Long
    Dim DestinationArray            As Variant, SourceArray         As Variant
    Dim wsDestination               As Worksheet, wsSource          As Worksheet
'
    ArrayColumnNumberStart = 1                                                                                  ' <--- Set this to the start column
    DataBlockSize = 4                                                                                           ' <--- Set this to the # of columns per block
    StartRowOfHeader = 1                                                                                        ' <--- Set this to the start row
    Set wsDestination = Sheets("Sheet2")                                                                        ' <--- Set this to the destination sheet
    Set wsSource = Sheets("Sheet1")                                                                             ' <--- Set this to the source sheet
'
    LastColumnNumberInSheet = Sheets("Sheet1").Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column  ' Returns last Column Number in sheet
    LastRowInSheet = Sheets("Sheet1").Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row                 ' Returns last Row Number in sheet
    NumberOfDataBlocks = LastColumnNumberInSheet / DataBlockSize                                                ' Returns # of Data sections
    ColumnNumberOffset = 0                                                                                      ' Initialize the ColumnNumberOffset
'
    ReDim SourceArray(1 To NumberOfDataBlocks)                                                                  ' Set the # of arrays to be used
'
    For LastRowInBlockRangeFinder = 1 To NumberOfDataBlocks                                                   ' Loop through each data range to find last row
        LastRowInBlockRange = wsSource.Range(wsSource.Cells(StartRowOfHeader, _
                ArrayColumnNumberStart + ColumnNumberOffset), wsSource.Cells(LastRowInSheet, _
                ColumnNumberOffset + DataBlockSize)).Find("*", , xlFormulas, , xlByRows, xlPrevious).Row        ' Find last Row Number of each block of data
'
        SourceArray(LastRowInBlockRangeFinder) = wsSource.Range(wsSource.Cells(StartRowOfHeader, _
                ArrayColumnNumberStart + ColumnNumberOffset), wsSource.Cells(LastRowInBlockRange, _
                ColumnNumberOffset + DataBlockSize))                                                            ' Save each range of data into SourceArray
'
        ColumnNumberOffset = ColumnNumberOffset + DataBlockSize                                                 ' Adjust the ColumnNumberOffset for next range
    Next                                                                                                        ' Loop back
'
' At this point, all of the data blocks have been loaded to the 3D 1 based SourceArray (Array#)(R,C)
'
    DestinationArrayRow = 0                                                                                     ' Initialize DestinationArrayRow
    ReDim DestinationArray(1 To NumberOfDataBlocks * LastRowInSheet, 1 To DataBlockSize)                ' Set the Row size & Column size of DestinationArray
'
    For ArrayNumber = 1 To NumberOfDataBlocks                                                                   ' Loop through each array
        For ArrayRow = LBound(SourceArray(ArrayNumber)) To UBound(SourceArray(ArrayNumber))                     '   Loop through each array row
            DestinationArrayRow = DestinationArrayRow + 1                                                       '       Increment DestinationArrayRow
'
            For ArrayColumnNumber = 1 To DataBlockSize                                                          '       Loop through each array column
                DestinationArray(DestinationArrayRow, ArrayColumnNumber) = _
                        SourceArray(ArrayNumber)(ArrayRow, ArrayColumnNumber)                                   '           Save result to DestinationArray
            Next                                                                                                '       Loop back
        Next                                                                                                    '   Loop back
    Next                                                                                                        ' Loop back
'
    wsDestination.Range("A1").Resize(UBound(DestinationArray, 1), UBound(DestinationArray, 2)) = DestinationArray   ' Display Final results to destination
'
    Application.ScreenUpdating = False                                                                          ' Turn ScreenUpdating back on
'
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."                                       ' Display the time elapsed to the user (Ctrl-G)
End Sub

 

[Dippy001]

Thank you so much @kevin9999 & @johnnyL they both work great thank you so so much ??

 

[kevin9999]

Thank you so much @kevin9999 & @johnnyL they both work great thank you so so much ??

Glad we could help and thanks for the feedback, although I should point out that the code from @johnnyL is light years ahead of mine ?