How do I copy and paste cells and then delete certain rows in a specific way using excel VBA? - excel

Question

I have to preface this by saying I am below the lowest level of novice when it comes to VBA. I currently have a single column of data in excel where information about companies is stored in groups of three rows as you descend down the column. The data is grouped as follows (no empty rows between the data):
CompanyA
www.CompanyA.com
CompanyA location
CompanyB
www.CompanyB.com
CompanyB location... etc.
I need to create a code that will copy the cell below, paste it to cell to the right, then delete the row below. Then copy the cell that is now below, and paste it two to the right, then select the next cell down and repeat for the next three row dataset. I've included my terrible first draft below if this helps explain my thinking. Any help would be very much appreciated. Thank you!
Sub Clean()
Do Until IsEmpty(ActiveCell.Value)
Range("A1").Activate
Selection.Offset(1, 0).Copy
Selection.Offset(0, 1).Paste
ActiveCell.Offset(1, 0).EntireRow.Delete xlShiftUp
Selection.Offset(1, 0).Copy
Selection.Offset(0, 2).Paste
ActiveCell.Offset(1, 0).EntireRow.Delete xlShiftUp
ActiveCell.Offset(1, 0).Select
Loop
End Sub

Answer 1

This could help you do what you want. Not the best solution out there but this will loop through all the cells slightly faster than what you have done.
Sub test()
Dim lRow As Long, i As Long
Dim ws As Worksheet
Dim RowsToDelete As Range
Set ws = ActiveSheet
With ws
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row ' Get the last row
For i = lRow To 1 Step -3
.Cells(i - 2, 3) = .Cells(i, 1)
.Cells(i - 2, 2) = .Cells(i - 1, 1)
If RowsToDelete Is Nothing Then 'first 2 rows to be deleted
Set RowsToDelete = Range(.Rows(i).EntireRow, .Rows(i - 1).EntireRow)
Else 'append more rows with union
Set RowsToDelete = Application.Union(RowsToDelete, .Rows(i).EntireRow, .Rows(i - 1).EntireRow)
End If
Next i
If Not RowsToDelete Is Nothing Then 'if there is something to be deleted
RowsToDelete.Delete
End If
End With
End Sub

Answer 2

You should try to avoid using ActiveCell and Selection in most cases. User input while the code is running can mess up your position and yields unpredictable results.
Its best to pull the data into an array, process your changes and output the data. This method also happens to be faster as you're not constantly reading and writing data to the sheet.
Something like the below will perform better for large data sets and will not be affected by user input during runtime:
Sub GatherCompanyData()
Dim Temp As Variant, Target As Range
Dim x As Long, c As Long, MyOutput As Variant
'First cell containing data [UPDATE THIS AS NEEDED]
Set Target = Sheets("SHEET NAME HERE").Range("A1")
'Get all the data in specified column
With Target.Parent
Temp = .Range(Target.Cells(1, 1).Address, .Cells(.Rows.Count, Target.Column).End(xlUp).Address).Value
End With
'Build Output Data
ReDim MyOutput(1 To Int(UBound(Temp, 1) / 3), 1 To 3)
For x = 3 To UBound(Temp, 1) Step 3
c = c + 1
MyOutput(c, 1) = Temp(x - 2, 1)
MyOutput(c, 2) = Temp(x - 1, 1)
MyOutput(c, 3) = Temp(x, 1)
Next x
'Clear existing data and output new data
Target.Value = Empty
Target.Resize(c, 3).Value = MyOutput
End Sub

Answer 3

I think I actually just figured it out. I'm sure this isn't the most elegant solution but it works. Curious if anyone has a better way of solving this. Thanks!
Sub Clean()
Range("A1").Activate
Do Until IsEmpty(ActiveCell.Value)
Selection.Offset(1, 0).Copy
Selection.Offset(0, 1).Select
ActiveCell.PasteSpecial xlPasteAll
ActiveCell.Offset(1, 0).EntireRow.Delete xlShiftUp
Selection.Offset(1, -1).Select
ActiveCell.Copy
Selection.Offset(-1, 2).Select
ActiveCell.PasteSpecial xlPasteAll
ActiveCell.Offset(1, 0).EntireRow.Delete xlShiftUp
Selection.Offset(1, -2).Select
Loop
End Sub