Sub SelectAllNonBlankCells()
Dim objUsedRange As Range
Dim objRange As Range
Dim objNonblankRange As Range
Application.ScreenUpdating = False
Set sh = Worksheets("Summary") ' Summary Sheet
sh.Range("A11:P1000").Clear
Set objUsedRange = Application.ActiveSheet.Range("B4:B15")
For Each objRange In objUsedRange
If Not (objRange.Value = "" And objRange.MergeCells = True) Then
If objNonblankRange Is Nothing Then
Set objNonblankRange = objRange
Else
Set objNonblankRange = Application.Union(objNonblankRange, objRange)
End If
End If
Next
If Not (objNonblankRange Is Nothing) Then
objNonblankRange.Copy
sh.Range("B11").PasteSpecial Transpose:=True
End If
End Sub