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

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

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 2

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