قائمة بما قمت بتحديده

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