عبدالله بشير عبدالله

وعليكم السلام 
جرب الكود المعدل بالملف
تغيير لون الخلايا المحدده بالماوس من خلال اليوزر فورم_085825.xlsm

وعليكم السلام ورحمة الله وبركاته
الكود المرفق يقوم :-
بالغاء حماية الشيتات المستهدفة 123 ثم يتم اظهار الصفوف 1-2 ثم يمسح الصور السابقة  
بعد ادراج الصور يتم اخفاء الصفوف1-2 ثم حماية الصفحات من جديد 123
استبدل الكود السابق بهذا
تم تجربة الكود على 28 صفحة في  حدود 3 الى 4 ثانية
Private Sub CommandButton13_Click() Dim ws As Worksheet Dim Pic As Shape Dim shp As Shape Dim rng As Range Dim fd As FileDialog Dim imgPath As String Dim i As Long Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Title = "اختر الصورة المراد إدراجها" .Filters.Clear .Filters.Add "جميع الصور", "*.jpg; *.jpeg; *.png; *.bmp; *.gif; *.tiff" .AllowMultiSelect = False If .Show = -1 Then imgPath = .SelectedItems(1) Else Exit Sub End If End With Application.ScreenUpdating = False On Error Resume Next Application.CommandBars.FindControl(ID:=549).Execute On Error GoTo 0 For Each ws In Worksheets If ws.Name <> "قائمة" And ws.Name <> "مخزن" Then On Error Resume Next ws.Unprotect Password:="123" On Error GoTo 0 ws.Rows("1:2").Hidden = False Set rng = ws.Range("A2:V2") For i = ws.Shapes.Count To 1 Step -1 Set shp = ws.Shapes(i) If shp.Type = msoPicture Or shp.Type = msoLinkedPicture Then On Error Resume Next If Not Intersect(shp.TopLeftCell, rng) Is Nothing Then shp.Delete End If On Error GoTo 0 End If Next i Set Pic = ws.Shapes.AddPicture( _ Filename:=imgPath, _ LinkToFile:=msoFalse, _ SaveWithDocument:=msoTrue, _ Left:=rng.Left, _ Top:=rng.Top, _ Width:=rng.Width, _ Height:=rng.Height) With Pic .LockAspectRatio = msoFalse .Placement = xlMoveAndSize End With ws.Rows("1:2").Hidden = True ws.Protect Password:="123" End If Next ws Application.ScreenUpdating = True MsgBox "تم إدراج الصورة بنجاح!", vbInformation, "تم بنجاح" End Sub كما يمكنك  الغاء اكوادالحماية وغيرها من ملفك لانها اصبحث من صمن الكود السابق

تم التعديل 
الكود حاليا  يقوم بحذف اي صور من النطاق a2:v2  قبل ادراج الصورة الجديدة حتى لا تتراكم الصور فوق بعضها
كذلك تم تعديل اسم الصورة ومكانها على الجهاز بحيث يمكنك احتيار اي صورة وباي اسم وباي امتداد من الجهاز ويمكنك  اضافة اي امتداد اخر غير مدرج بالكود
.Filters.Add "جميع الصور", "*.jpg; *.jpeg; *.png; *.bmp; *.gif; *.tiff" تم استتناء ورقة3-ورقة6 من ادراج الصور ويمكنك استتناء المزيد وذلك باظافة اسم الورقة بالكود من الجزء 
For Each ws In Worksheets If ws.Name <> "ورقة3" And ws.Name <> "ورقة6" Then ادراج صورة (2).xlsm

السلام عليكم
يمكن عمل ذلك بقك الحماية في بداية اي كود ثم اعادة الحماية في نهاية الكود
كلمة الحماية 123 يمكنك تعديلها بالكود
جدول الحراسة.xlsm
 

وعليكم السلام ورحمة الله وبركاته
اليك الحل 
بالمعادلات في شيت1
بالاكواد شيت2
مثال1.xlsb

وعليكم السلام ورحمة الله وبركاته
كود صغير يقوم بالامر
Sub CopyCtoB_IfBlank() Dim i As Long For i = 2 To Cells(Rows.Count, "C").End(xlUp).Row If IsEmpty(Cells(i, "B")) And Not IsEmpty(Cells(i, "C")) Then Cells(i, "B").Value = Cells(i, "C").Value End If Next i End Sub  

جرب التعديل التالي
115.xlsm

وعليكم السلام ورحمة الله وبركاته
هذه الدالة تقوم بالمهمة ان شاء الله  صعها في f3 ثم اسحب لاسفل
تحياتي
=IF(B3="فروج مسحب"; D3*E3*2.55; D3*E3*1.85)  

السلام عليكم ورحمة الله وبركاته
 

وعليكم السلام ورحمة الله وبركاته
جرب الكود حيث قبل التنفيذ، يقوم بحذف أي دوائر سابقة
1الثالث.xlsb
 
 
 

وعليكم السلام ورحمة الله وبركاته
كل عام وانت بخير
 الصفحات كثيرة وهذا سيجعل اي كود يستغرق وقتا اطول لاستدعاء البيانات استغرق على جهازي حوالي 6 دقائق بمعدل ثانية واحدة لكل صفحة
فكرة الاكواد ؟ الكود الاول (اسعار الاسهم ) يتم تشغيله مرة واحدة فقط ويستغرق عدة دقائق بعدها يتم التعامل مع زر التحديت ويستغرق اقل من دقيقة واحدة
من خلال 3 مواقع ذكاء اصطناعي تحصلت على  افضل كود يقوم بالمهمة 
التجرية تمت على اكسل 2016 لانه ليس لدي 2010 واعتقد ان الكود يعمل علي 2010
زر التحديث / بعد استدعاء البيانات يقوم زر التحديث بمقارنة البيانات المستدعاة بالموقع واذا كان هناك تغير يقوم يالتحديث
قم بالتجربة واعلمنا بالنتائج
افضل الاكواد تحصلت عليها من موقع https://chat.deepseek.com/
us_stocks_arincen (1).xlsb
 
 

وعليكم السلام ورحمة الله وبركاته
بالنسبة للاوقات التي خارج الاوقات في  M&N لم تحدده وفي اي بصمة تسجل
تم ربط المعادلات حسب الاوقات في M&N
اكسل1.xlsm
 

حرب التعديل التالي
توزيع عدد الحصص (233) (1).xlsm

وعليكم السلام 
نعم اعلم ان هناك طلب ثاني وكان ردي السابق لطلبك الاول
اليك الملف وبه طلبك الثاني
Plateform19840019.xlsb

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

 
 
 اختر لا ستفتح واجهة كما بالصورة  

قم بالاختيار حسب الصف المحدد  ثم حفظ
casse 2026 .xlsb

السلام عليكم 
نعم المشكلة من حماية الشيتات
 اليك التعديل مع اظافة الترقيم التلقائي لرقم التسجيل
Plateform (1) .xlsb
 
 
 

اليك  التعديل
Plateform (1).xlsb
 
 

اليك التعديل 
Plateform.xlsb

السلام عليكم 
تم عمل الاحصائيات  
الملف المرفق به الاحصاء  
Plateform3.xlsb
الشريط المتحرك ليس لدي جلفية لعملة ولا اراه مهما لانه سيسبب ثقل للملف
ا1ذا تحققت طلباتك ارجو فتح موضوع جديد  لاي طلب جديد وهذا حسب قوانين المنتدى

وعليكم السلام ورحمة الله وبركاته
اليك التعديل المطلوب 
Horaire1.xlsb

اولا / الملف السابق به كودين كلاهما معاينة تم تعديل احدهما الى طباعة
ثانيا  :- للتطبيق على ملفك / احعل لغة الجهاز العربية وانسخ الكود المرفق وفي ملفك الاخر قم بالدخول إلى صفحة الفيجوال بيسك عن طريق التبويب Developer(المطور) ثم Visual Basic    ثم من قائمة Insert  اختر  Module  والصقه  به واربطه بزر في الصفحة المراد ترقيمها
ملاحطة/ الكود المرفق مهمته الطباعة مع الترقيم
ان اردت المعاينة مع الترقيم بدون طباعة غير  كلمة FALSE الى TRUE في الجملة   ws.PrintOut From:=i, To:=i, Preview:=False
Sub طباعة() Dim ws As Worksheet Dim totalPages As Long Dim i As Long Dim pageNum As Integer Set ws = ActiveSheet totalPages = (ws.HPageBreaks.Count + 1) * (ws.VPageBreaks.Count + 1) For i = 1 To totalPages pageNum = Application.WorksheetFunction.RoundUp(i / 2, 0) If i Mod 2 <> 0 Then ws.PageSetup.CenterFooter = "الصفحة " & Format(pageNum, "00") Else ws.PageSetup.CenterFooter = "تابع الصفحة " & Format(pageNum, "00") End If ws.PrintOut From:=i, To:=i, Preview:=False Next i End Sub  

وعليكم السلام ورحمة الله وبركاته .
ارى الحل في الغاء جميع معادلات الصفيف واالابقاء على الاسماء في النطاق AA16:AA  وبدل المعادلات كود في حدث الورقة
ملاحظة هامة 
اذا اردت نقل الكود الى ملف اخر به الكمبوبكس1 يجب اجراء بعض التعديلات على اعدادات الكمبوبكس1
افتح الكمبوبكس في وضع التصميم  ثم خصائص تم امسخ البيانات في الدائرة الحمراء كما في الصورة  كذلك قم بمسخ المعادلات 

تقبل الله صيامكم وطاعاتكم
حل مشكل القائمة المنسدلةباستخدام ComboBox1.xlsm

وعليكم السلام ورحمة الله وبركاته
الحل هو نقل الكود إلى موديول (Module) عادي وتخصيص زر  لتشغيله فقط عندما تضيف أوراق عمل جديدة
اليك التعديل بالمرفق
المصنف2.xlsm
 
 

جرب التعديل التالي 
 
لا ننس كتابة اسم الملف في الحلية A2
الكل (1) (2).xlsm
لا حرج ان اردت اي تعديل احر

وعليكم السلام ورحمة الله وبركاته
يتم الامر في حطوة واحدة