Making My Code More Efficient in VBA

Question

Top Table

What Top Table should looks like afterward

Bottom Table

What Bottom Table should looks like afterwards

I have the following code that basically copy the last two rows from the first table and then insert the rows below. Then I will delete certain part of the cells from the inserted rows. As you can see there is a pattern, 4,5,6....7,8,9....,11,12,13.... etc

Then, it will go to the bottom table and copy the row above "DOS" and insert it below. Afterwards, it'll copy the cell from column "OUT" from the row above and paste it to the row below.

The first problem that I am having is that the Union only take up to 30 arguments, but I have more than 30 rng.

I'd like to make my code more efficient using for loop or something

Sub BajaFresh_Update()
        Range("A1").Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
        Union(ActiveCell.EntireRow, ActiveCell.Resize(1).Offset(-1).EntireRow).Copy
        ActiveCell.Resize(1).Offset(1).EntireRow.Insert Shift:=xlDown
        Application.CutCopyMode = False


        Set rng1 = ActiveCell.Offset(1, 4)
        Set rng2 = ActiveCell.Offset(2, 4)
        Set rng3 = ActiveCell.Offset(1, 5)
        Set rng4 = ActiveCell.Offset(2, 5)
        Set rng5 = ActiveCell.Offset(1, 6)
        Set rng6 = ActiveCell.Offset(2, 6)
        Set rng7 = ActiveCell.Offset(1, 8)
        Set rng8 = ActiveCell.Offset(2, 8)
        Set rng9 = ActiveCell.Offset(1, 9)
        Set rng10 = ActiveCell.Offset(2, 9)
        Set rng11 = ActiveCell.Offset(1, 10)
        Set rng12 = ActiveCell.Offset(2, 10)
        Set rng13 = ActiveCell.Offset(1, 12)
        Set rng14 = ActiveCell.Offset(2, 12)
        Set rng15 = ActiveCell.Offset(1, 13)
        Set rng16 = ActiveCell.Offset(2, 13)
        Set rng17 = ActiveCell.Offset(1, 14)
        Set rng18 = ActiveCell.Offset(2, 14)
        Set rng19 = ActiveCell.Offset(1, 16)
        Set rng20 = ActiveCell.Offset(2, 16)
        Set rng21 = ActiveCell.Offset(1, 17)
        Set rng22 = ActiveCell.Offset(2, 17)
        Set rng23 = ActiveCell.Offset(1, 18)
        Set rng24 = ActiveCell.Offset(2, 18)
        Set rng25 = ActiveCell.Offset(1, 20)
        Set rng26 = ActiveCell.Offset(2, 20)
        Set rng27 = ActiveCell.Offset(1, 21)
        Set rng28 = ActiveCell.Offset(2, 21)
        Set rng29 = ActiveCell.Offset(1, 22)
        Set rng30 = ActiveCell.Offset(2, 22)
        Set rng31 = ActiveCell.Offset(1, 24)
        Set rng32 = ActiveCell.Offset(2, 24)
        Set rng33 = ActiveCell.Offset(2, 25)
        Set rng34 = ActiveCell.Offset(2, 25)
        Set rng35 = ActiveCell.Offset(2, 26)
        Set rng36 = ActiveCell.Offset(2, 26)


        Union(rng1, rng2, rng3, rng4, rng5, rng6, rng7, rng8, rng9, rng10, rng11, rng12, rng13, rng14, rng15, rng16, rng17, rng18, rng19, rng20, rng21, rng22, rng23, rng24, rng25, rng26, rng27, rng28, rng29, rng30).ClearContents
        Union(rng32, rng33, rng34, rng35, rng36).ClearContents
        ActiveCell.End(xlDown).Select
        ActiveCell.End(xlDown).Select
        ActiveCell.Offset(-6).EntireRow.Copy
        ActiveCell.Offset(-5).Select
        ActiveCell.EntireRow.Insert Shift:=xlDown
        Application.CutCopyMode = False

        Set copy1 = ActiveCell.Offset(-2, 5)
        Set copy2 = ActiveCell.Offset(-2, 9)
        Set copy3 = ActiveCell.Offset(-2, 13)
        Set copy4 = ActiveCell.Offset(-2, 17)
        Set copy5 = ActiveCell.Offset(-2, 21)
        Set copy6 = ActiveCell.Offset(-2, 25)
        Set paste1 = ActiveCell.Offset(-1, 5)
        Set paste2 = ActiveCell.Offset(-1, 9)
        Set paste3 = ActiveCell.Offset(-1, 13)
        Set paste4 = ActiveCell.Offset(-1, 17)
        Set paste5 = ActiveCell.Offset(-1, 21)
        Set paste6 = ActiveCell.Offset(-1, 25)
        copy1.Copy
        ActiveSheet.Paste paste1
        copy2.Copy
        ActiveSheet.Paste paste2
        copy3.Copy
        ActiveSheet.Paste paste3
        copy4.Copy
        ActiveSheet.Paste paste4
        copy5.Copy
        ActiveSheet.Paste paste5
        copy6.Copy
        ActiveSheet.Paste paste6




        End Sub

Answer 1

Highly recomend taking @Craners advice left in comment. Remove all instances of .Select & .ActiveCell. I left them here, but you should work to remove all of them.

---

I believe you can use this to round up your 30 ranges into a single varible: MyUnion. Once loop is done, you can then just refer to MyUnion which contains all of the individual ranges (MyUnion.ClearContents, MyUnion.Copy, etc.)

You can apply similar logic to other loops. This will knock out your first, and larges, loop though!

Dim MyUnion As Range, iRow As Integer, iCol As Integer

For iCol = 4 To 26
    If iCol <> 7 Or iCol <> 15 Or iCol <> 19 Or iCol <> 23 Then 'Skip these columns
        For iRow = 1 To 2
            If MyUnion Is Nothing Then
                Set MyUnion = ActiveCell.Offset(iRow, iCol)
            Else
                Set MyUnion = Union(MyUnion, ActiveCell.Offset(iRow, iCol))
            End If
        Next iRow
    End If
Next iCol

Msgbox "REMOVE .SELECT OR ELSE CRANER WILL FIND YOU" vbCritical

GL :)