Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.Cells(1, 1).Column = 1 Then Exit Sub
If Selection.Cells.Count > 50 Then
MsgBox "Too Many Data"
Exit Sub
End If
Dim lasteRow
Dim x%, i%: i = 1
lasteRow = Cells(Rows.Count, 1).End(3).Row
If lasteRow = 1 Then lasteRow = 2
If Application.CountA(Target) = 0 Then
With Range("A1")
.Value = Selection.Address
With .Offset(1)
.Resize(lasteRow, 1).Clear
.Value = "Selection is Empty "
.Interior.ColorIndex = 8
End With
With .Offset(2)
.Value = "ActiveCell is : " & ActiveCell.Address
.Interior.ColorIndex = 3
.Font.ColorIndex = 2
End With
End With
Exit Sub
End If
Dim arr()
Dim k%: k = 1
Dim cel As Range
For Each cel In Selection
If cel <> vbNullString Then
ReDim Preserve arr(1 To k)
arr(k) = cel.Value
k = k + 1
Else: x = x + 1
End If
i = i + 1
Next
With Me.Range("a1")
.Value = Selection.Address
.Offset(1).Resize(lasteRow, 1).Clear
.Offset(1).Resize(k - 1, 1).Value = Application.Transpose(arr)
With .Offset(k)
.Value = "Active Cell is : " & ActiveCell.Address
.Interior.ColorIndex = 3
.Font.ColorIndex = 2
With .Offset(1)
.Value = "Items: " & Selection.Cells.Count - x
.Interior.ColorIndex = 7
.Font.ColorIndex = 2
End With
End With
End With
Me.Range("A:A").Columns.AutoFit
Range("B1") = "Selection Address"
Erase arr
End Sub