Copy paste rows until change in value in Column B into the next empty column in another Sheet

[manjuprasad]

I have 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.

Thanks you in advance.

 

[Joe4]

Welcome to the Board!

Try this:

Sub MyCopyPaste()

    Dim r As Long
    Dim fr As Long
    Dim grp As String
    Dim lastRow As Long
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    
    Set sht1 = Worksheets("Sheet1")
    Set sht2 = Worksheets("Sheet2")
    
    sht1.Activate
        
    Application.ScreenUpdating = False
    
'   Capture last row on sheet 1
    lastRow = sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row

'   Set first group and first row number
    grp = sht1.Range("B2")
    fr = 2

'   Loop through all data rows
    For r = 2 To lastRow
'       See if group number is different from one below
        If sht1.Cells(r + 1, "B") <> grp Then
'           Set rng and copy to destination sheet
            If r = 2 Then
                sht1.Range(Cells(fr, "A"), Cells(r, "D")).Copy sht2.Cells(2, "A")
            Else
                sht1.Range(Cells(fr, "A"), Cells(r, "D")).Copy sht2.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1)
            End If
'           Reset values
            grp = sht1.Cells(r + 1, "B")
            fr = r + 1
        End If
    Next r
    
    Application.ScreenUpdating = True
    
    MsgBox "Macro complete!"
    
End Sub

 

[Z51]

This may also work:

Sub manjuprasad()
Dim i As Long, j As Long, n As Long, lastrow As Long
Dim nextCol As Long, curVal As String, ws1 As Worksheet, ws2 As Worksheet

Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
n = 1
nextCol = 1
lastrow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
curVal = ws1.Cells(2, 2).Value

For i = 2 To lastrow
    For j = 2 To lastrow
        If ws1.Cells(j, 2).Value = curVal Then n = j
    Next j
    ws2.Cells(1, nextCol).Resize(n - i + 1, 4).Value = ws1.Cells(i, 1).Resize(n - i + 1, 4).Value
    i = n
    curVal = ws1.Cells(i + 1, 2).Value
    nextCol = nextCol + 4
Next i
End Sub

 

[manjuprasad]

Welcome to the Board!

Try this:

Sub MyCopyPaste()

    Dim r As Long
    Dim fr As Long
    Dim grp As String
    Dim lastRow As Long
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
   
    Set sht1 = Worksheets("Sheet1")
    Set sht2 = Worksheets("Sheet2")
   
    sht1.Activate
       
    Application.ScreenUpdating = False
   
'   Capture last row on sheet 1
    lastRow = sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row

'   Set first group and first row number
    grp = sht1.Range("B2")
    fr = 2

'   Loop through all data rows
    For r = 2 To lastRow
'       See if group number is different from one below
        If sht1.Cells(r + 1, "B") <> grp Then
'           Set rng and copy to destination sheet
            If r = 2 Then
                sht1.Range(Cells(fr, "A"), Cells(r, "D")).Copy sht2.Cells(2, "A")
            Else
                sht1.Range(Cells(fr, "A"), Cells(r, "D")).Copy sht2.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1)
            End If
'           Reset values
            grp = sht1.Cells(r + 1, "B")
            fr = r + 1
        End If
    Next r
   
    Application.ScreenUpdating = True
   
    MsgBox "Macro complete!"
   
End Sub

This perfectly works for me. Thank you very much. You made my day.

 

[manjuprasad]

This may also work:

Sub manjuprasad()
Dim i As Long, j As Long, n As Long, lastrow As Long
Dim nextCol As Long, curVal As String, ws1 As Worksheet, ws2 As Worksheet

Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
n = 1
nextCol = 1
lastrow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
curVal = ws1.Cells(2, 2).Value

For i = 2 To lastrow
    For j = 2 To lastrow
        If ws1.Cells(j, 2).Value = curVal Then n = j
    Next j
    ws2.Cells(1, nextCol).Resize(n - i + 1, 4).Value = ws1.Cells(i, 1).Resize(n - i + 1, 4).Value
    i = n
    curVal = ws1.Cells(i + 1, 2).Value
    nextCol = nextCol + 4
Next i
End Sub

This too works perfectly. Thank you very much.

 

[Joe4]

You are welcome.
Glad that we could help.