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

 

[oldbrewer]

can we see some data, there may be a different way to approach it....

 

[mumps]

Can you explain in words in detail what you are trying to do. Better still, perhaps you could upload a copy of your file to a free site such as www.box.com. or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Include a detailed explanation of what you would like to do referring to specific cells and worksheets. If the workbook contains confidential information, you could replace it with generic data. It is always easier to test possible solutions using your actual file.

 

[ddoctor]

Here is a link to the file

https://www.dropbox.com/s/w0o2e54j00st3et/FINISHEDLOG1.xlsm?dl=0

And here is a short video explanation, I haven't been able to get across what I'm doing through words very well. This was made about a week ago, so there is more included now and a lot of junk/test code was removed, but it sums up what I'm doing pretty well.

https://youtu.be/DWOwJfIVRGY

Overall I'm creating a spreadsheet to track employee training hours. The first tab is the master list that will have courses added to it. The macro in question will assign and duplicate the course to each individual so that I can track if they have taken it or not through table slicers.

 

[mumps]

I'm sorry but the video you posted isn't very helpful and the code the way it is written is hard to decipher. It also generated errors. When I tried to run one of your macros, my Excel froze. Generally, you don't have to select a cell to copy it or to paste to it. For example, the following code:

Sub Test()
    Range("A1").Select
    Selection.Copy
    Range("A2").Select
    Selection.PasteSpecial
    Application.CutCopyMode = False
End Sub

can be replaced with:

Sub Test2()
    Range("A1").Copy Range("A2")
End Sub

 

[Fluff]

Not sure if this is quite, but try

Sub Organize_Data()

    Dim Rng1 As Range, Rng2 As Range, Rng3 As Range
    Dim Cnt As Long
    Dim Rw As Long, Rws 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)
        Rws = Rng1.Rows.Count
        Rw = 11
        
        For Cnt = 1 To 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 = Rw + Rws
        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

 

[ddoctor]

Not sure if this is quite, but try

Sub Organize_Data()

    Dim Rng1 As Range, Rng2 As Range, Rng3 As Range
    Dim Cnt As Long
    Dim Rw As Long, Rws 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)
        Rws = Rng1.Rows.Count
        Rw = 11
        
        For Cnt = 1 To 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 = Rw + Rws
        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

This is so amazingly close! I can't express how much I appreciate it! The only issue is that it doesn't seem to run all the way through the list. Below is a link to a screenshot of where the issue is. Unfortunately I'm not familiar enough with how this code works yet to figure it out. I'll be playing with it in the meantime though.

https://www.dropbox.com/s/vd9ymjgpwyd4vq6/ScrnShot.png?dl=0

 

[ddoctor]

Rw = Rw + Rws

Found the culprit

 

[Fluff]

Hadn't seen your sheet when I created the code. The problem was that Col D was longer than the others.
Try

Sub Organize_Data()

    Dim Rng1 As Range, Rng2 As Range, Rng3 As Range
    Dim Cnt As Long
    Dim Rw As Long, Rws 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)
        Rws = Rng1.Rows.Count
        Rw = 11
        
        For Cnt = 1 To Range("D11").End(xlDown).Row - 11
            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 = Rw + Rws
        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

 

[ddoctor]

Hadn't seen your sheet when I created the code. The problem was that Col D was longer than the others.
Try

Sub Organize_Data()

    Dim Rng1 As Range, Rng2 As Range, Rng3 As Range
    Dim Cnt As Long
    Dim Rw As Long, Rws 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)
        Rws = Rng1.Rows.Count
        Rw = 11
        
        For Cnt = 1 To Range("D11").End(xlDown).Row - 11
            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 = Rw + Rws
        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

Now when it gets to the 13th name it repeats it

https://www.dropbox.com/s/vd9ymjgpwyd4vq6/ScrnShot.png?dl=0