VBA code for cutting and pasting data

runmageddon

New Member
Joined
Oct 25, 2019
Messages
3
Hi there,

I have a question related to creating a macro in VBA (data and desired outcome below). I have a table in Excel, where in column A and H I have data. In column A there are classes and in the column H are students. I would like to have only one row for one class and currently I have only one student in one row and there are blank columns as well. It looks like that: for example for class 1A I have in column A: and then in column H I have in the same row that "1A" Black, Jessica and then few rows below I have only Dark, James (with no "1A" in column A). I would like to have a macro that will copy Dark, James and others from this class into one cell - Black, Jessica. Could you please help me?

Data:
[TABLE="width: 500"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[/TR]
[TR]
[TD]1A[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Black, Jessica[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Dark, James[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2F[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Snow, Mark[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Maurick, Adam[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Smith, John[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Desired outcome:

[TABLE="width: 500"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[/TR]
[TR]
[TD]1A[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Black, Jessica
Dark, James[/TD]
[/TR]
[TR]
[TD]2F[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Snow, Mark
Maurick, Adam
Smith John[/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
Hi runmageddon,

Welcome to MrExcel!!

Try this (though initially on a copy of your data as the results cannot be undone if they're not as expected):

Code:
Option Explicit
Sub Macro1()

    Dim lngMyRow As Long
    Dim lngLastRow As Long
    Dim blnDeleteRow As Boolean
    
    Application.ScreenUpdating = False

    lngLastRow = Range("A:H").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = lngLastRow To 2 Step -1
        'If columns A to H of the 'lngMyRow' row are all blank, then...
        blnDeleteRow = Evaluate("SUMPRODUCT(--(A" & lngMyRow & ":H" & lngMyRow & "<>""""))=0")
        If blnDeleteRow = True Then
            '...delete that row
            Rows(lngMyRow).EntireRow.Delete
        End If
    Next lngMyRow
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert
 
Upvote 0
Robert,
It is almost working - it seems that this formula is removing blank rows. But I would like to have students from one class in one row (in fact one cell) - not in multiple rows. This is because I have a lot of classes (like 56 or something like this) so I want to have only that much rows.
 
Upvote 0
it seems that this formula is removing blank rows.

Yes that's exactly what's it's doing as that was my understanding for your post.

I'm sure there's a more succinct way of doing this but see how this goes (again on a copy of your data) as it worked for me:

Code:
Option Explicit
Sub Macro1()

    Dim lngMyRow As Long
    Dim lngLastRow As Long
    Dim lngPasteRow As Long
    Dim blnDeleteRow As Boolean
    Dim strNames As String
    
    Application.ScreenUpdating = False

    lngLastRow = Range("A:H").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = 2 To lngLastRow
        If Len(Range("A" & lngMyRow)) > 0 Then
            If lngPasteRow = 0 Then
                lngPasteRow = lngMyRow
            Else
                Range("H" & lngPasteRow) = strNames
                lngPasteRow = lngMyRow
                strNames = ""
            End If
        End If
        If Len(Range("H" & lngMyRow)) > 0 Then
            If Len(strNames) = 0 Then
                strNames = Range("H" & lngMyRow)
            Else
                strNames = strNames & vbCrLf & Range("H" & lngMyRow)
            End If
            Range("H" & lngMyRow).ClearContents
        End If
    Next lngMyRow
    
    Range("H" & lngPasteRow) = strNames
    
    For lngMyRow = lngLastRow To 2 Step -1
        'If columns A to H of the 'lngMyRow' row are all blank, then...
        blnDeleteRow = Evaluate("SUMPRODUCT(--(A" & lngMyRow & ":H" & lngMyRow & "<>""""))=0")
        If blnDeleteRow = True Then
            '...delete that row
            Rows(lngMyRow).EntireRow.Delete
        End If
    Next lngMyRow
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert
 
Last edited:
Upvote 0

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top