VBA Paste below collapsed Group

Question

I have a macro that copies rows from a Sheet named "Template" and pastes them onto the Active Sheet in the next blank row.

However this macro only works when the grouped cells on the Active Sheet are expanded. If the grouped cells are collapsed, then the macro replaces a previous collapsed group.

I have done some reading and discovered that using a different method to calculate the last row i.e. the MergeArea property would work with collapsed groups but just sure how to apply it.

How could I achieve this with the current code?

This is my code:

Sub Paste_New_Product_from_Template()
    Dim copySheet As Worksheet
    Dim pasteSheet As Worksheet
    Dim LRow As Long, i As Long
    Dim StartNumber As Long
    Dim varString As String
    
    '~~> This is your input sheet
    Set copySheet = ThisWorkbook.Worksheets("Template")
 
    '~~> Variable
    varString = copySheet.Cells(2, 2).Value2
    
    '~~> Change this to the relevant sheet
    Set pasteSheet = ThisWorkbook.ActiveSheet
    
    '~~> Initialize the start number
    StartNumber = 1
    
    With pasteSheet
        '~~> Find the last cell to write to
        If Application.WorksheetFunction.CountA(.Cells) = 0 Then   
            LRow = 2
        Else
            LRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
            
            '~~> Find the previous number
            For i = LRow To 1 Step -1
                If .Cells(i, 2).Value2 = varString Then
                    StartNumber = .Cells(i, 6).Value2 + 1
                    Exit For
                End If
            Next i
        End If
        
        copySheet.Range("2:" & copySheet.Cells(Rows.Count, 1).End(xlUp).Row).Copy
        .Rows(LRow).PasteSpecial Paste:=xlPasteAll
        
        '~~> Set the start number
        .Cells(LRow, 6).Value = StartNumber

        '~~> Format the number
        .Cells(LRow, 6).Value = "'" & Format(StartNumber, "000") 
    End With
End Sub

Here is the code that uses the MergeArea procedure:

Private Function RowIsEmpty(WSh As Worksheet, Row As Long, StartColumnNumber As Integer, EndColumnNuber As Integer) As Boolean
  Dim j As Integer

  RowIsEmpty = True
  
  For j = StartColumnNumber To EndColumnNuber
    If (WSh.Cells(WSh.Cells(Row, j).MergeArea.Row, WSh.Cells(Row, j).MergeArea.Column) <> "") Then
      RowIsEmpty = False
      Exit For 'One of columns isn't empty
    End If
  Next j
End Function


Private Function CalcLastRowNumber(WSh As Worksheet, StartColumnNumber As Integer, EndColumnNuber As Integer) As Long
  Dim i As Long
  Dim j As Integer
  Dim Result As Long
  Dim Found As Boolean
  
  Result = 1
  For i = 1 To Rows.Count
    If RowIsEmpty(WSh, i, StartColumnNumber, EndColumnNuber) And _
      RowIsEmpty(WSh, i + 1, StartColumnNumber, EndColumnNuber) And _
      RowIsEmpty(WSh, i + 2, StartColumnNumber, EndColumnNuber) Then
                   'Stop searching
          Exit For 'All Columns are empty for current row and for next 2 rows
    End If
    Result = i
  Next i
  CalcLastRowNumber = Result
End Function

Sub New_Reviss_Order()

VBA Paste below collapsed Group

0 Answers