VBA code for cutting and pasting data

[runmageddon]

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:

A	B	C	D	E	F	G	H
1A							Black, Jessica
							Dark, James
2F							Snow, Mark
							Maurick, Adam
							Smith, John

<tbody>
</tbody>

Desired outcome:

A	B	C	D	E	F	G	H
1A							Black, Jessica Dark, James
2F							Snow, Mark Maurick, Adam Smith John

<tbody>
</tbody>

 

[Trebor76]

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):

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

 

[runmageddon]

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.

 

[Trebor76]

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:

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

 

[runmageddon]

Thank you very much Robert, this code is perfect for my data :D

 

[Trebor76]

Thanks for letting us know and you're welcome