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

S

seaottr

Board Regular
Joined
Feb 10, 2010
Messages
60
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]B[/TD]
[TD="align: center"]C[/TD]
[TD="align: center"]D[/TD]
[TD="align: center"]E[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]12345[/TD]
[TD]4[/TD]
[TD]No[/TD]
[TD]Green Car[/TD]
[TD]Yes[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]12345[/TD]
[TD]2[/TD]
[TD]Yes[/TD]
[TD]Red[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]Truck[/TD]
[TD]No[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]23456[/TD]
[TD]1[/TD]
[TD]Yes[/TD]
[TD]Blue[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]Airplane[/TD]
[TD]No[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD]34567[/TD]
[TD]2[/TD]
[TD]Yes[/TD]
[TD]Yellow Bike[/TD]
[TD]Yes[/TD]
[/TR]
[TR]
[TD]10[/TD]
[TD]34567[/TD]
[TD]1[/TD]
[TD]No[/TD]
[TD]Purple Taxi[/TD]
[TD]No[/TD]
[/TR]
</tbody>[/TABLE]


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:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]B[/TD]
[TD="align: center"]C[/TD]
[TD="align: center"]D[/TD]
[TD="align: center"]E[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]12345[/TD]
[TD]4[/TD]
[TD]No[/TD]
[TD]Green Car[/TD]
[TD]Yes[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]12345[/TD]
[TD]2[/TD]
[TD]Yes[/TD]
[TD]Red Truck[/TD]
[TD]No[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]23456[/TD]
[TD]1[/TD]
[TD]Yes[/TD]
[TD]Blue Airplane[/TD]
[TD]No[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]34567[/TD]
[TD]2[/TD]
[TD]Yes[/TD]
[TD]Yellow Bike[/TD]
[TD]Yes[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]34567[/TD]
[TD]1[/TD]
[TD]No[/TD]
[TD]Purple Taxi[/TD]
[TD]No[/TD]
[/TR]
</tbody>[/TABLE]


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

Thank you in advance!
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Sort by date Sort by votes
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
 
Upvote 0
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
 
Last edited:
Upvote 0
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!!!
 
Last edited:
Upvote 0
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!!!!
 
Upvote 0
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
Click to expand...
 
Upvote 0
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]
 
Upvote 0
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]
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
VBA code to cut and paste multiple filtered rows based on multiple criteria
Replies
2
Views
1K
Alex Blakenburg
A
G
  • Solved
Input the correct data when match
Replies
4
Views
186
etaf
etaf
S
  • Solved
Worksheet Change Event
Replies
3
Views
598
sspatriots
S
J
  • Question Question
Copy cell content with an if condition + small loop (VBA Excel)
Replies
7
Views
797
mumps
mumps
WildBurrow
  • Question Question
Copy/Paste data to next empty row within a range - WITHOUT shifting subsequent rows up
Replies
0
Views
422
WildBurrow
WildBurrow

Forum statistics

Threads
1,224,823
Messages
6,181,177
Members
453,021
Latest member
Justyna P

Share this page

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