VBA to loop through worksheet and cut/paste cells after every blank row

seaottr · Apr 11, 2018

Hi all,

I won't get into the reasons why, because I know people are going to try to solve for a different problem, but I have a data set that has blank rows, and the next row needs to be cut and appended to another column in the previous non-blank row.

Below is an sample data set:

	A	B	C	D	E
1	12345	4	No	Green Car	Yes
2	12345	2	Yes	Red
3
4	Truck	No
5	23456	1	Yes	Blue
6
7	Airplane	No
8
9	34567	2	Yes	Yellow Bike	Yes
10	34567	1	No	Purple Taxi	No

I basically need the contents from A4 to be appended to D2 and the content from B4 to go into E2

I would then like to delete rows 3 and 4 and then continue doing the same thing for the rest of the data set. Output below:

	A	B	C	D	E
1	12345	4	No	Green Car	Yes
2	12345	2	Yes	Red Truck	No
3	23456	1	Yes	Blue Airplane	No
4	34567	2	Yes	Yellow Bike	Yes
5	34567	1	No	Purple Taxi	No

This sounds really complicated, but was hoping the experts here can help!

Thank you in advance!

MickG · Apr 12, 2018

Try this:-

Code:

[COLOR="Navy"]Sub[/COLOR] MG12Apr39
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Temp [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not Temp [COLOR="Navy"]Is[/COLOR] Nothing And Not IsEmpty(Dn.Value) And Not IsNumeric(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        Temp.Offset(, 3) = Temp.Offset(, 3) & " " & Dn.Value
        Temp.Offset(, 4) = Dn.Offset(, 1).Value
        Dn.Value = ""
    [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]If[/COLOR] IsNumeric(Dn.Value) And Not IsEmpty(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Temp = Dn
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
Rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

skorpionkz · Apr 12, 2018

I know that MickG gave you perfectly working code, but as I finished alternative one, I will paste it anyway.
P.S. I also know it is overkill for this request...

In standard module paste this code:

Code:

Option Explicit

Sub FixTable()

Dim myColl As New Collection
Dim myItem As cls_FixTable
Dim myArr() As Variant
Dim LR As Long
Dim LC As Long
Dim l_Row As Long
Dim l_Count As Long

LR = Cells.Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
LC = Cells.Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column

myArr = Range(Cells(1, 1), Cells(LR, LC))

For l_Row = 1 To LR
    If myArr(l_Row, 1) = Empty Then
    ElseIf IsNumeric(myArr(l_Row, 1)) Then
        Set myItem = New cls_FixTable
        With myItem
            .A = myArr(l_Row, 1)
            .B = myArr(l_Row, 2)
            .C = myArr(l_Row, 3)
            .D = myArr(l_Row, 4)
            .E = myArr(l_Row, 5)
            
            myColl.Add myItem
        End With
    ElseIf Not myItem Is Nothing Then
        With myItem
            .D = .D & " " & myArr(l_Row, 1)
            .E = myArr(l_Row, 2)
        End With
    End If
Next l_Row

Set myItem = Nothing
l_Count = 0

ReDim myArr(1 To myColl.Count, 1 To 5)

For Each myItem In myColl
    l_Count = l_Count + 1
    
    With myItem
        myArr(l_Count, 1) = .A
        myArr(l_Count, 2) = .B
        myArr(l_Count, 3) = .C
        myArr(l_Count, 4) = .D
        myArr(l_Count, 5) = .E
    End With
Next myItem

Range(Cells(1, 1), Cells(LR, LC)).Clear
Range(Cells(1, 1), Cells(l_Count, LC)) = myArr
End Sub

then create class module, name it "cls_FixTable" and paste below code

Code:

Option Explicit

Private pA As Long
Private pB As Integer
Private pC As String
Private pD As String
Private pE As String

Public Property Let A(ByVal myValue As Long)
    pA = myValue
End Property
Public Property Get A() As Long
    A = pA
End Property

Public Property Let B(ByVal myValue As Integer)
    pB = myValue
End Property
Public Property Get B() As Integer
    B = pB
End Property

Public Property Let C(ByVal myValue As String)
    pC = myValue
End Property
Public Property Get C() As String
    C = pC
End Property

Public Property Let D(ByVal myValue As String)
    pD = myValue
End Property
Public Property Get D() As String
    D = pD
End Property

Public Property Let E(ByVal myValue As String)
    pE = myValue
End Property
Public Property Get E() As String
    E = pE
End Property

seaottr · Apr 15, 2018

Thank you SO much for this solution MickG!!! It works awesome! However, it's not deleting the row that it copied from. Column A is actually formatted as text (and needs to be, to avoid losing leading zeroes). Does it have to do with the fact that column A is a text formatted field? Are you able to provide some guidance on what I would need to change in your above code to ensure that the row that was copied and pasted above is deleted? In my Example, A4 would be the row that isn't deleted.

Here is a link to the actual file that I'm using: https://drive.google.com/open?id=1389-TghKWlgaXVtQFygJztnvzeBZal1D

Column A data is being appended to column P, and columns B, C, D, E, F, G and H are copied/pasted to each respective column after P (I was surprisingly able to tweak your code to achieve this).

Thank you SO MUCH again!!!

seaottr · Apr 15, 2018

I appreciate you working on a solution skorpionkz! Thank you so much! I decided to go with MickG's solution because it was a little easier for me to understand/follow (because I'm by no means a good VBA coder)

Thanks again!!!!

seaottr · Apr 15, 2018

Thank you SO much for this solution MickG!!! It works awesome! However, it's not deleting the row that it copied from. Column A is actually formatted as text (and needs to be, to avoid losing leading zeroes). Does it have to do with the fact that column A is a text formatted field? Are you able to provide some guidance on what I would need to change in your above code to ensure that the row that was copied and pasted above is deleted? In my Example, A4 would be the row that isn't deleted.

Here is a link to the actual file that I'm using: https://drive.google.com/open?id=138...gJztnvzeBZal1D

Column A data is being appended to column P, and columns B, C, D, E, F, G and H are copied/pasted to each respective column after P (I was surprisingly able to tweak your code to achieve this).

Thank you SO MUCH again!!!

MickG said:

Try this:-

Code:

[COLOR=navy]Sub[/COLOR] MG12Apr39
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, Temp [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
    [COLOR=navy]If[/COLOR] Not Temp [COLOR=navy]Is[/COLOR] Nothing And Not IsEmpty(Dn.Value) And Not IsNumeric(Dn.Value) [COLOR=navy]Then[/COLOR]
        Temp.Offset(, 3) = Temp.Offset(, 3) & " " & Dn.Value
        Temp.Offset(, 4) = Dn.Offset(, 1).Value
        Dn.Value = ""
    [COLOR=navy]End[/COLOR] If
    [COLOR=navy]If[/COLOR] IsNumeric(Dn.Value) And Not IsEmpty(Dn.Value) [COLOR=navy]Then[/COLOR]
        [COLOR=navy]Set[/COLOR] Temp = Dn
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] Dn
Rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

MickG · Apr 16, 2018

For the basic code to delete rows as required, try changing the code as below.

Change This:-

Code:

Temp.Offset(, 3) = Temp.Offset(, 3) & " " & Dn.Value
        Temp.Offset(, 4) = Dn.Offset(, 1).Value
       [B][COLOR=#FF0000] Dn.Value = ""[/COLOR][/B]

To this:-

Code:

Temp.Offset(, 3) = Temp.Offset(, 3) & " " & Dn.Value
        Temp.Offset(, 4) = Dn.Offset(, 1).Value
           [B][COLOR=#ff0000]Dn.ClearContents[/COLOR][/B]

seaottr · Apr 16, 2018

You're a superstar MickG!! That did the trick! Thanks again!

MickG said:
For the basic code to delete rows as required, try changing the code as below.

Change This:-

Code:

Temp.Offset(, 3) = Temp.Offset(, 3) & " " & Dn.Value Temp.Offset(, 4) = Dn.Offset(, 1).Value [B][COLOR=#ff0000] Dn.Value = ""[/COLOR][/B]

To this:-

Code:

Temp.Offset(, 3) = Temp.Offset(, 3) & " " & Dn.Value Temp.Offset(, 4) = Dn.Offset(, 1).Value [B][COLOR=#ff0000]Dn.ClearContents[/COLOR][/B]

MickG · Apr 16, 2018

You're elcome

VBA to loop through worksheet and cut/paste cells after every blank row

seaottr

Board Regular

Excel Facts

MickG

MrExcel MVP

skorpionkz

Well-known Member

seaottr

Board Regular

seaottr

Board Regular

seaottr

Board Regular

MickG

MrExcel MVP

seaottr

Board Regular

MickG

MrExcel MVP

Similar threads

Forum statistics

Share this page

VBA to loop through worksheet and cut/paste cells after every blank row

Board Regular

Excel Facts

MrExcel MVP

Well-known Member

Board Regular

Board Regular

Board Regular

MrExcel MVP

Board Regular

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock