رجب جاويش

اذا كنت تقصد منع تحريك الشكل او تغيير حجمه انظر الصور التالية

السلام عليكم تفضل أخى TABLE WITH PROTECT 1.rar

تفضل أخى هذا شرح مختصر للكود Sub ragab() 'السطور التالية لتعريف المتغيرات Dim cl As Range, LR As Integer Dim sh As Worksheet, R_N As Integer 'تحديد الورقة التى سوف يتعامل المتغير معها Set sh = ورقة3 '=========================================== 'السطر التالى لوقف اهتزاز الشاشة لتسريع عمل الكود Application.ScreenUpdating = False 'تحديد قيمة خلية رقم السند x = [G13] 'تحديد اول سطر فارغ فى العمود الخاص برقم السند فى الورقة 3 LR = sh.[G1000].End(xlUp).Row + 1 'نسخ الخلايا من ورقة الادخال Range("A13:K13").Copy 'حلقى تكرارية لمعرفة هل رقم السند مكرر داخل الورقة 3 ام لا For Each cl In sh.Range("G13:G" & LR) If cl = x Then 'اذا وجد رقم السند مكرر يتم تحديد رقم الصف الخاص به من السطر التالى R_N = cl.Row 'يتم لصق البيانات الجديدة مكان البيانات القديمة فى الورقة 3 sh.Cells(R_N, 1).PasteSpecial xlPasteValues 'وبعد لصق البيانات الجديدة مكان القديمة يتجة الى السطر الخاص بانهاء خاصية القص والنسخ GoTo 1 End If Next 'اذا لم يكن رقم السند مكرر فيتم نسخة فى صف جديد عن طريق السطر التالى sh.Cells(LR, 1).PasteSpecial xlPasteValues 'السطر الخاص بانهاء خاصية القص والنسخ لازالة التحديد الموجود حول الخلايا المنسوخة 1: Application.CutCopyMode = False ' اعادة اهتزار الشاشة كما كان Application.ScreenUpdating = True End Sub

بعد اذن أخى الفاضل سليم جرب أخى هذه الفكرة تم عمل قائمة غير مكررة من اسم القرية وخطوط العرض والطول الخاصة بها فى الأعمدة J , K , L وتم عمل قائمة منسدلة فى العمود E كما تريد وعند اختيار اسم القرية يظهر خط الطول وخط العرض تلقائيا فى الخلايا المجاورة ملاحظة : عند وجود قرى جديدة يتم اضافتها واضافة خط العرض وخط الطول الخاص بها فى الأعمدة J , K , L وسوف يتم اضافتها تلقائيا الى القائمة المنسدلة المرنة please 1.rar

أخى الفاضل محمد هذا السطر لانهاء خاصية النسخ او القص حتى يتم ازالة الخطوط المنقطة حول الخلايا التى تم نسخها

جزاك الله خيرا اخى محمد

أخى محمد يرجى توضيح الخطأ الذى يحدث حتى تتم الاستفادة وتلافى هذا الخطأ

أخى محمد تم اضافة تعديل بسيط جدا للكود لا يؤثر فى عملية الترحيل

أخى محمد جرب الكود التالى Sub ragab() Dim cl As Range, LR As Integer Dim sh As Worksheet, R_N As Integer Set sh = ورقة3 '=========================================== Application.ScreenUpdating = False x = [G13] LR = sh.[G1000].End(xlUp).Row + 1 Range("A13:K13").Copy For Each cl In sh.Range("G13:G" & LR) If cl = x Then R_N = cl.Row sh.Cells(R_N, 1).PasteSpecial xlPasteValues GoTo 1 End If Next sh.Cells(LR, 1).PasteSpecial xlPasteValues 1: Application.CutCopyMode = False Application.ScreenUpdating = True End Sub ترحيل.rar ترحيل.rar

الحمد لله جزاك الله خيرا أخى محمد

ونعم المعلم والمتابع أجمل تحياتى واحترامى للأستاذ ياسر خليل

جزاك الله خيرا أخى الحبيب على هذا التشجيع

جزاك الله كل خير على هذا الابداع

شكرا جزيلا للأستاذ المبدع / ياسر العربى وجزاك الله كل خير

بعد اذن أخى الحبيب ياسر ربما هذا ما يقصده أخونا محمد ايصالي1.rar

أخى الحبيب الخلوق / محمود الشريف المنتدى نور بطلتك المميزة ربنا يبارك فيك ان شاء الله نسعد بوجودك المستمر

أخى الفاضل / أتش الحمد لله أن تم المطلوب جزاك الله خيرا

أخى الفاضل كمال جزاك الله كل خير على الاستجابة السريعة ومرحبا بك فى منتدانا العريق أخى الفاضل مهند وفقنا الله واياكم الى ما فيه الخير والسداد

أخى الفاضل مهند تسلم ايديك أخى الفاضل كمال مرحبا بك بين أخوانك وجزاك الله خيرا وأدعوك الى تغير اسم الظهور الى اللغة العربية ليسهل التواصل بيننا طبقا لسياسة المنتدى

وتكون النتيجة كما بالملف المرفق spin.rar

بعد اذن الأستاذ الفاضل / ياسر العربى ولاثراء الموضوع بناءا على فكرة أخى الفاضل أحمد الفلاحجى مارأيكم بهذه الفكرة Private Sub Worksheet_SelectionChange(ByVal Target As Range) x = Application.WorksheetFunction.CountA(Range("A:A")) + 2 If Not Intersect(Target, Range("A:A")) Is Nothing Then Sheet1.Unprotect "123" ActiveSheet.ListObjects("Table1").Resize Range("$A$2:$N" & x) Range("$A$2:$N" & x).Locked = False End If Sheet1.Protect "123" End Sub TABLE WITH PROTECT 1.rar

جزاك الله خيرا أخى الفاضل عبد العزيز

على شكر على واجب أخى الفاضل

بعد اذن أخى الفاضل سليم ولاثراء الموضوع جرب أخى هذا الكود Sub ragab() Dim LR As Integer, LR1 As Integer, i As Integer, x As Integer Dim sh As Worksheet, cl As Range, TT As Integer, DD As Integer Set sh = Sheet1 '=================================================================== On Error Resume Next If IsEmpty(Range("C1")) Or Not IsNumeric(Range("C1")) Then Exit Sub TT = [C1] Range("A4:D1000").ClearContents LR = sh.Range("B1000").End(xlUp).Row - 1 DD = LR - Application.WorksheetFunction.CountIf(sh.Range("E2:E" & LR + 1), "ok") If DD = 0 Then MsgBox ("لا يوجد أسماء متاحة للاختيار منها") Exit Sub End If MsgBox ("عدد الأسماء المتاح الإختيار منها " & " " & DD) If TT > DD Then Exit Sub 1: x = Int(Rnd(1) * LR + 1) LR1 = Range("A1000").End(xlUp).Row '=================================================================== If sh.Cells(x + 1, 5) = "ok" Then GoTo 1 For Each cl In Range("A4:A" & LR1) If cl = x - 1 Then GoTo 1 Exit For End If Next '=================================================================== For i = 1 To 4 Cells(LR1 + 1, i) = sh.Cells(x + 1, i) Next sh.Cells(x + 1, 5) = "ok" R = R + 1 If R = TT Then Exit Sub GoTo 1 End Sub اسماء السائقين ومكان عملهم1.rar

أخى الفاضل جرب المرفق مثال توضيحي.rar