looking for an elegant solution to dealing with merged cells

Question

Happy friday everyone,

I've been scratching my head over this for the past week now and finally given up - hope someone more talented than me (which shouldn't be difficult) can suggest something.

Please bare in mind I'm a complete novice - I got this code by copying something someone had online and making simple modifications - thank you

The code does something simple - it arranges all rows bringing those with "Singapore" in column E to the top and pasted it in another worksheet. The issue now is there is a new format I'm dealing with - shown in below screenshot (there is now an additional row of comments which are always merged when pasted)

I'm trying to modify the code to bring the contents of the merged cells on to the right of the bolded rows - example of the desired result in image below

  Sub CopySINGAPOREtoParsesheet()

    Sheets("PASTEHERE").Select
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
    Dim i As Long
    Dim ws As Worksheet, nws As Worksheet
    Set ws = ActiveSheet
    LastRow = Cells(Rows.Count, "E").End(xlUp).Row
    Dim wsName As String: wsName = "parse"
    If (Worksheets("parse").Name = "") Then
        Sheets("PASTEHERE").Copy After:=Sheets("PASTEHERE")
        ActiveSheet.Name = "parse"
        Range("A2:XFD" & LastRow).ClearContents
    Else
        Sheets("parse").Select
    End If
    Set nws = ActiveSheet
    For i = 2 To LastRow
        ws.Select
        If UCase(Cells(i, "E")) = "SINGAPORE" Then
            Range(("A" & i) & ":" & ("H" & i)).Copy
            nws.Select
            nsLR = Cells(Rows.Count, "A").End(xlUp).Row
            Range("A" & nsLR + 1).Select
               
           ActiveSheet.Paste
            
         '   Range("H" & i).Copy
          '  Selection.PasteSpecial Paste:=xlPasteValues
            
        End If
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = True
    On Error GoTo 0
    nws.Select
    Range("A2").Select
    
    For i = 2 To LastRow
        ws.Select
        If UCase(Cells(i, "E")) <> "SINGAPORE" And UCase(Cells(i, "A")) <> UCase(Cells(i, "E")) Then
            Range(("A" & i) & ":" & ("H" & i)).Copy
            nws.Select
            nsLR = Cells(Rows.Count, "A").End(xlUp).Row
            Range("A" & nsLR + 1).Select
           
            
            ActiveSheet.Paste
            
           ' Range("H" & i).Copy
          '  Selection.PasteSpecial Paste:=xlPasteValues

        End If
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = True
    On Error GoTo 0
    nws.Select
    Range("A2").Select
          
End Sub

Answer 1

Few things to highlight:

1. As mentioned in comment - Please read up on how to avoid using Select. Selecting cell/worksheet is considered a bad practice and is unnecessary overhead as that's for human interaction, code can work with the object directly and so is faster and safer (no chance to get error due to wrong ActiveCell/ActiveSheet)

2. You should declare all variables used in the code. Please insert Option Explicit at the top of your module to help you enforce this.

Please try the code below:

Option Explicit

Sub CopySINGAPOREtoParsesheet()
    Const srcWSName As String = "PASTEHERE"
    Const newWSName As String = "parse"
        
    Dim srcWS As Worksheet
    Set srcWS = ThisWorkbook.Sheets(srcWSName)
    
    Application.ScreenUpdating = False
        
    Dim newWS As Worksheet
    
    'Error set to check if worksheet exist, create a new worksheet if there isn't
    On Error Resume Next
    Set newWS = ThisWorkbook.Sheets(newWSName)
    If newWS Is Nothing Then
        srcWS.Copy after:=srcWS
        Set newWS = ActiveSheet
        
        With newWS
            .Name = newWSName
            .UsedRange.UnMerge
            .UsedRange.ClearContents
        End With
    End If
    On Error GoTo 0
            
    Dim srcLastRow As Long
    srcLastRow = srcWS.Cells(srcWS.Rows.Count, "E").End(xlUp).Row
    
    Dim newLastRow As Long
    newLastRow = newWS.Cells(newWS.Rows.Count, "A").End(xlUp).Row
    
    Dim i As Long
    
    'Loop through source worksheet for Singapore rows
    For i = 2 To srcLastRow
       If UCase(srcWS.Cells(i, "E")) = "SINGAPORE" Then
            srcWS.Range(Replace("A!:G!", "!", i)).Copy newWS.Range(Replace("A!:G!", "!", newLastRow))
            srcWS.Cells(i + 1, "A").Copy newWS.Cells(newLastRow, "H")
            newLastRow = newLastRow + 1
        End If
    Next i
    
    'Loop through source worksheet again for Non-Singapore rows
    For i = 2 To srcLastRow
                        
        If UCase(srcWS.Cells(i, "E")) <> "SINGAPORE" Then
            If srcWS.Cells(i, "E").MergeArea.Cells.Count = 1 Then
                srcWS.Range(Replace("A!:G!", "!", i)).Copy newWS.Range(Replace("A!:G!", "!", newLastRow))
                srcWS.Cells(i + 1, "A").Copy newWS.Cells(newLastRow, "H")
                newLastRow = newLastRow + 1
            End If
        End If
    Next i
    
    Application.ScreenUpdating = True
    
    newWS.Select
    newWS.Cells(2, 1).Select
End Sub