I have a data in Excel Sheet1, which is as follows:

I have to organize the data where I want to copy all the data rows based on "Column B" into a separate sheet until the last unique value in "Column B", which is shown below: I have around 6000 rows in my data set.

I have developed the following VBA code which copy every 6 rows and paste it in the last empty column in Sheet2. as shown below.

Sub copyPaste()

    Dim x As Long
    Dim y As Long
    Dim lastRow As Long

    Dim sht As Worksheet
    Set sht = Worksheets("Sheet1")
    
    y = 6
    lastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
    'emptyColumn = Sheet2.Cells(2, Columns.Count).End(xlToLeft).Column

    For x = 2 To lastRow Step 6
        If Worksheets("Sheet2").Cells(2, "A") = "" Then
            Worksheets("Sheet1").Range("A" & x & ":D" & y).Copy _
                    Destination:=Worksheets("Sheet2").Cells(2, "A")
        Else
            Worksheets("Sheet1").Range("A" & x & ":D" & y).Copy _
                    Destination:=Worksheets("Sheet2").Cells(2, Columns.Count).End(xlToLeft).Offset(, 1)
        End If
        y = y   6
    Next
End Sub

I kindly request if any of you have a solution to organize the data, as shown in image 2 above.

CodePudding user response：

Assuming your data is sorted on Person:

Sub copyPaste()
    Dim wsSource As Worksheet, cDest As Range, c As Range, n As Long
    
    Set wsSource = Worksheets("Sheet1")            'source data sheet
    Set c = wsSource.Range("B2")                   'first person name
    
    Set cDest = Worksheets("Sheet2").Range("A1")   'first paste destination
    
    Do While c.Value <> ""                                      'loop while have a name
        n = Application.CountIf(wsSource.Columns("B"), c.Value) 'how many rows for this person?
        c.Offset(0, -1).Resize(n, 4).Copy cDest                 'copy data over
        Set c = c.Offset(n)                                     'next name
        Set cDest = cDest.Offset(0, 4)                          'next paste location
    Loop
End Sub

CodePudding user response：

Stack Unique Rows Side By Side

• If copying the values (no formats or formulas) is good enough, you could use the following.

Option Explicit

Sub StackUniqueRowsSideBySide()
    
    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Reference the source worksheet ('sws').
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
    
    Dim srg As Range
    
    ' Reference the source range.
    With sws.Range("A1").CurrentRegion
        Set srg = .Resize(.Rows.Count - 1).Offset(1)
    End With
    
    ' Using the 'GetUniqueRowsSideBySide' function,
    ' return the stacked unique rows in a 2D one-based array ('dData').
    Dim dData As Variant: dData = GetUniqueRowsSideBySide(srg, 3, 0)
    
    ' Reference the destination worksheet ('dws').
    Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet2")
    
    ' Reference the destination first cell ('dfCell').
    Dim dfCell As Range: Set dfCell = dws.Range("A2")
        
    Dim drg As Range
        
    ' Reference the destination clear range ('drg').
    Set drg = dfCell.Resize(dws.Rows.Count - dfCell.Row   1, _
        dws.Columns.Count - dfCell.Row   1)
    ' Clear previous data.
    drg.Clear
    
    ' Reference the destination range ('drg').
    Set drg = dfCell.Resize(UBound(dData, 1), UBound(dData, 2))
    ' Write new data.
    drg.Value = dData

End Sub

Function GetUniqueRowsSideBySide( _
    ByVal srg As Range, _
    Optional ByVal UniqueColumn As Long = 1, _
    Optional ByVal ColumnGap As Long = 0) _
As Variant
    
    ' Write the number of source rows and columns
    ' to variables ('srCount', 'scCount').
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim scCount As Long: scCount = srg.Columns.Count
    
    ' Write the values from the source range to a 2D one-based array,
    ' the source array ('sData').
    Dim sData() As Variant: sData = srg.Value
    
    ' Create and reference a new dictionary object ('dict').
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive
    
    Dim sKey As Variant
    Dim sr As Long
    
    ' Write each unique value from the unique column ('UniqueColumn')
    ' of the source array to a 'key' of the dictionary and write
    ' the current row to the collection held in the associated 'item'.
    For sr = 1 To srCount
        sKey = sData(sr, UniqueColumn)
        If Not dict.Exists(sKey) Then
            Set dict(sKey) = New Collection
        End If
        dict(sKey).Add sr
    Next sr
            
    Dim drCount As Long
    
    ' Determine the destination rows count ('drCount'),
    ' the number of items in the largest collection ('dict(sKey)').
    For Each sKey In dict.Keys
        If dict(sKey).Count > drCount Then drCount = dict(sKey).Count
    Next sKey
    
    ' Calculate the destination columns count ('drCount').
    Dim dcCount As Long
    dcCount = dict.Count * (scCount   ColumnGap) - ColumnGap
    
    ' Define the destination array ('dData').
    Dim dData() As Variant: ReDim dData(1 To drCount, 1 To dcCount)
     
    Dim sItem As Variant
    Dim sk As Long
    Dim sc As Long
     
    Dim dr As Long
    Dim dcOffset As Long
     
    ' Using the information in the dictionary, return the stacked unique rows
    ' from the source array in the destination array.
    For Each sKey In dict.Keys
        sk = sk   1
        dcOffset = (sk - 1) * (scCount   ColumnGap)
        For Each sItem In dict(sKey)
            dr = dr   1
            For sc = 1 To scCount
                dData(dr, sc   dcOffset) = sData(sItem, sc)
            Next sc
        Next sItem
        dr = 0
    Next sKey
    
    ' Assign the destination array to the result of the function.
    GetUniqueRowsSideBySide = dData
    
End Function