ابراهيم الحداد

السلام عليكم ورحمة الله انسخ هذا الكود والصقه فى محرر الاكواد وخصص له زر Sub TrnsData() Application.ScreenUpdating = False For i = 1 To Sheets.Count For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> "toc" Then Sh.Range("B10:G10").Copy For R = 2 To Range("A" & Rows.Count).End(xlUp).Row If Range("A" & R) = Sh.Name Then Range("F" & R).PasteSpecial xlPasteValues End If Next End If Application.CutCopyMode = False Next Next Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله بعد اذن اخى ابو عبد النور الملف بدون تغيير الاسماء من اللغة العربية ahmad.rar

السلام عليكم ورحمة الله يمكنك عمل هذا من خلال فتح مصنف جديد ومن خلاله يتم فتح الملف المذكور ثم الدخول الى محررالاكواد ومسح الكود اوالتعليمة المسببة للمشكلة

السلام عليكم ورحمة الله يمكنك الآن العودة الى صفحة العمل والتعديل كما شئت PROJET11.rar

السلام عليكم ورحمة الله تم حفظ الملف بامتداد مختلف لخلل فى القائمة المنسدلة اليك الملف Liste.rar

السلام عليكم ورحمة الله اكتب هذا الكود فى حدث الورقة 2 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$H$15" Or Target.Address = "$H$17" Then For R = 4 To 9 If Target.Value = Sheet1.Cells(R, 3).Value Then Target.Interior.ColorIndex = Sheet1.Cells(R, 3).Interior.ColorIndex End If Next End If End Sub

السلام عليكم ورحمة الله تفضل اخى الكريم حالة.rar

السلام عليكم ورحمة الله استبدل الكود السابق بهذا الكود Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False On Error Resume Next Dim R As Integer LR = Range("A" & Rows.Count).End(xlUp).Row + 1 If Not Intersect(Target.Cells(1, 1), Union(Range("B3:B4000"), Range("o3:o5000"))) Is Nothing Then R = Target.Row If Cells(R, "B").Value <> "" Then If Cells(LR - 1, "A").Value <= 99 Then Cells(R, "A").Value = R + 44 'محتاج التعديل على الكود حيث يبداء الترقم من 44 ويتوقف عن الترقيم عند الرقم 100 Else End If End If End If Application.ScreenUpdating = True On Error GoTo 0 End Sub

السلام عليكم ورحمة الله تفضل حالة.rar

السلام عليكم ورحمة الله تفضل Book1.rar

السلام عليكم ورحمة الله تفضل اخى الكريم هشام 22.rar

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

السلام عليكم ورحمة الله اليك المطلوب سيعطيك الملف رسالة فى حالة زيادة النسبة " ا " عن النسة " ب " والعكس برنامج توزيع مبلغ اضافى.rar

السلام عليكم ورحمة الله تفضل أخى الكريم المثال.rar

السلام عليكم ورحمة الله تم التعديل Nouveau dossier.rar

السلام عليكم ورحمة الله تكتب هكذا =A4 *$B$4 وتسحب نزولا

السلام عليكم ورحمة الله تفضل اخى الكريم Nouveau dossier.rar

السلام عليكم ورحمة الله تم تعديل الكود ولكنه يستغرق وقتا فى التنفيذ استبدل الكود السابق بهذا الكود Sub Tra_Data3() Application.ScreenUpdating = False LR = Sheet12.Range("B" & Rows.Count).End(xlUp).Row For R = 13 To LR For F = 13 To Cells(Rows.Count, "C").End(xlUp).Row If Cells(F, "C") = Sheet12.Cells(R, "B") Then Sheet12.Range("C" & R).Range("A1:D1").Copy Range("D" & F).PasteSpecial xlPasteValues End If Next Next Application.CutCopyMode = False MsgBox " تم بحمد الله " Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله اكتب المعادلة التالية فى الخلية "B2" ثم اسحب نزولا =SUMIF(Sheet1!$A$1:$A$24;$A2;Sheet1!$B$1:$B$24)

السلام عليكم ورحمة الله تم استبدال المعادلة بكود لنسخ البيانات المطلوبة Book1.rar

السلام عليكم ورحمة الله تفضل أخى الكريم لتنقل بين الصفحات عن طريق الفورم.rar

السلام عليكم ورحمة الله انسخ هذا الكود فى موديول جديد وخصص له زر Sub SumCols() LR = Range("A" & Rows.Count).End(xlUp).Row + 1 For R = 2 To LR Step 2 x = 0 For C = 8 To 1 Step -1 x = x + Cells(R - 1, C) Cells(R, C) = x Next Next End Sub

السلام عليكم ورحمة الله تفضل أخى الكريم لتنقل بين الصفحات عن طريق الفورم.rar

الحمد لله الذى تتم بنعمته الصالحات

السلام عليكم ورحمة الله جرب هذا الكود Private Sub Workbook_Open() cell = WorksheetFunction.Sum(Range("A1:A100")) If cell = 100 Then MsgBox "TRUE" Else MsgBox "FALSE" End If End Sub