سليم حاصبيا قام بنشر أغسطس 1, 2018 قام بنشر أغسطس 1, 2018 اذا كنت تريد ان يظهر لك ما يحتوي التحديد الذي قمت به (بدون الخلايا الفارغة) استعمل هذا الملف الكود 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% 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 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 GET adderss of selection.xlsm 7 1
Ali Mohamed Ali قام بنشر أغسطس 1, 2018 قام بنشر أغسطس 1, 2018 بارك الله فيك استاذنا سليم دائما مبدع جزاك الله كل خير 1
أحمد يوسف قام بنشر أغسطس 1, 2018 قام بنشر أغسطس 1, 2018 أحسنت استاذ سليم بارك الله فيك ملف وكود رائعان 1
abushuber قام بنشر أغسطس 3, 2018 قام بنشر أغسطس 3, 2018 استاذ اي تحديدوالله تقصد.. اني عدي كوكبو بوكس لو حددت احد خياراتها اقصد الشيتات التي بداخلها هستظهر ليةمحتويات الشيت المحدد
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.