Offsetting cell without .select command

[ddoctor]

Is there a way to offeset the cell selection without using .select? I have a macro that requires a lot of cell offsetting as it runs, but the .select commands are slowing things down to much. I've read a lot about ways to remove .select, but with all the copying and pasting this macro does I don't know how to make it any more efficient.

Simply put, can this be wrote in a more efficient way?

ActiveCell.Offset(1, 0).Select

Here's the full code I'm working with

Sub Organize_Data()
MSG1 = MsgBox("Are you sure you want to recreate course list? If yes ensure Table is Converted to a Range and Cell Borders are set to 'No Border'.", vbYesNo, "Yadda?")
If MSG1 = vbYes Then
Application.ScreenUpdating = False

Set RNG1 = Range("C11:C" & Range("C11").End(xlDown).Row)
Set RNG2 = Range("E11:E" & Range("E11").End(xlDown).Row)
Set RNG3 = Range("F11:F" & Range("F11").End(xlDown).Row)

Range("D11").Select
Do Until IsEmpty(ActiveCell.Offset(1, 0))
Do Until IsEmpty(ActiveCell.Offset(1, -1))
Selection.Copy
ActiveCell.Offset(1, 0).Select
Selection.Insert Shift:=xlDown
Loop

ActiveCell.Offset(1, 0).Select
If IsEmpty(ActiveCell.Offset(0, -1)) Then
RNG1.Copy
ActiveCell.Offset(0, -1).Select
ActiveSheet.Paste
ActiveCell.Offset(0, 2).Select
RNG2.Copy
ActiveSheet.Paste
ActiveCell.Offset(0, 1).Select
RNG3.Copy
ActiveSheet.Paste
ActiveCell.Offset(0, -2).Select
End If
Loop

Range("D11").Select
Selection.End(xlDown).Select
Do Until IsEmpty(ActiveCell.Offset(1, -1))
Selection.Copy
ActiveCell.Offset(1, 0).Select
Selection.Insert Shift:=xlDown
Loop

Application.ScreenUpdating = True
Else
MsgBox "New Course List not generated"
End If
End Sub

 

[ddoctor]

Sub Organize_Data()

    Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range
    Dim Cnt As Long
    Dim Rw As Long, Rws As Long, Rows As Long
    Dim Msg1 As String

    Msg1 = MsgBox("Are you sure you want to recreate course list? If yes ensure Table is Converted to a Range and Cell Borders are set to 'No Border'.", vbYesNo, "Yadda?")
    If Msg1 = vbYes Then
    
        Application.ScreenUpdating = False
        
        Set Rng1 = Range("C11:C" & Range("C11").End(xlDown).Row)
        Set Rng2 = Range("E11:E" & Range("E11").End(xlDown).Row)
        Set Rng3 = Range("F11:F" & Range("F11").End(xlDown).Row)
        Set Rng4 = Range("D11:D" & Range("D11").End(xlDown).Row)
        Rws = Rng1.Rows.Count
        Row = Rng4.Rows.Count
        Rw = 11
        
        For Cnt = 1 To Row + Rws
            With Range("D" & Rw)
                .Offset(1).Resize(Rws - 1).Insert xlDown
                .Resize(Rws).FillDown
                .Offset(Rws, -1).Resize(Rws).Value = Rng1.Value
                .Offset(Rws, 1).Resize(Rws).Value = Rng2.Value
                .Offset(Rws, 2).Resize(Rws).Value = Rng3.Value
            End With
            Rw = Rows + Rws + Rw
        Next Cnt
        
        Range(Range("D11").End(xlDown), Range("D" & Range("C11").End(xlDown).Row)).FillDown
    
        Application.ScreenUpdating = True
    Else
        MsgBox "New Course List not generated"
    End If
    
End Sub

I've got it to run all the way through like this, but it just repeats the last name until it matches the cnt formula now.

 

[Fluff]

It works quite happily with the file you shared in post#4
Have you changed that file?

 

[ddoctor]

I didn't think I did, but when reopening the file I posted it works perfectly. I CANT THANK YOU ENOUGH!

 

[Fluff]

Glad to help & thanks for the feedback