Please Help! Having issues with copy&paste macro into grouped cells

[Keegan1116]

Hi everyone,

I have a macro that copy cells from a "data" sheet and pastes them +2 rows under my current work in my "Projects" sheet. The data that is copy & pasted is just a blank template that I can fill in when I start a new project. My "Projects" sheet consists of about 10 projects right now, all of which have a header (for name/location etc..) and a checklist underneath it for project deliverables and deadline dates.

The problem is, I always have the checklists grouped, so that I can collapse them all to see just the projects that I have on the go - It keeps everything easy to find and looking clean. This macro however, only works when the grouped cells (checklists) in "Projects" are expanded. If the grouped cells are collapsed, then the macro will replace some of the checklist for the last project in line, ie: it replaces the grouped cells that are collapsed instead of pasting +2 rows below the last grouped cell in the checklist.

How do I prevent this from happening? This macro was built mainly by another excel help forum page, as I am very new to macros. Here is the macro:

Sub New_Order()

Dim wss As Worksheet 'the source sheet
Dim wsd As Worksheet 'the destination sheet
Dim lr As Long 'to get first blank row on destination sheet

Set wss = ThisWorkbook.Worksheets("Data")
Set wsd = ThisWorkbook.Worksheets("Projects")
'get first blank row in destination sheet

lr = wsd.Range("C" & Rows.Count).End(xlUp).Row
Do While wsd.Rows(lr + 1).OutlineLevel > 1
  lr = lr + 1
Loop
lr = lr + 2
wss.Rows("2:36").Copy Destination:=wsd.Range("A" & lr)
Application.CutCopyMode = False

End Sub

 

[pbornemeier]

This might help. Test on a copy of your data.

Sub New_Order()

    Dim wss As Worksheet 'the source sheet
    Dim wsd As Worksheet 'the destination sheet
    Dim lr As Long 'to get first blank row on destination sheet
    Dim lMaxOutlineLevel As Long
    
    Set wss = ThisWorkbook.Worksheets("Data")
    Set wsd = ThisWorkbook.Worksheets("Projects")
    
    'ungroups all rows on destination sheet
    wsd.Outline.ShowLevels RowLevels:=8
    
    'get first blank row in destination sheet
    lr = wsd.Range("C" & Rows.Count).End(xlUp).Row
    
    Do While wsd.Rows(lr + 1).OutlineLevel > 1
      lr = lr + 1
    Loop
    lr = lr + 2

    wss.Rows("2:36").Copy Destination:=wsd.Range("A" & lr)  'Unless you are always copying 2:36
    'you may want to try
    'wss.Range("A2").CurrentRegion.Offset(1, 0).Copy Destination:=wsd.Range("A" & lr)
    
    
    Application.CutCopyMode = False

    wsd.Outline.ShowLevels RowLevels:=1  'Go back to group level 1
End Sub

 

[Keegan1116]

This might help. Test on a copy of your data.

Sub New_Order()

    Dim wss As Worksheet 'the source sheet
    Dim wsd As Worksheet 'the destination sheet
    Dim lr As Long 'to get first blank row on destination sheet
    Dim lMaxOutlineLevel As Long
   
    Set wss = ThisWorkbook.Worksheets("Data")
    Set wsd = ThisWorkbook.Worksheets("Projects")
   
    'ungroups all rows on destination sheet
    wsd.Outline.ShowLevels RowLevels:=8
   
    'get first blank row in destination sheet
    lr = wsd.Range("C" & Rows.Count).End(xlUp).Row
   
    Do While wsd.Rows(lr + 1).OutlineLevel > 1
      lr = lr + 1
    Loop
    lr = lr + 2

    wss.Rows("2:36").Copy Destination:=wsd.Range("A" & lr)  'Unless you are always copying 2:36
    'you may want to try
    'wss.Range("A2").CurrentRegion.Offset(1, 0).Copy Destination:=wsd.Range("A" & lr)
   
   
    Application.CutCopyMode = False

    wsd.Outline.ShowLevels RowLevels:=1  'Go back to group level 1
End Sub

Hi there!

Thank you so much for taking the time to write this out. It works like a charm!!!

 

[pbornemeier]

Glad to help.