أبو حنــــين

و عليكم السلام اخي حمادة جزاك الله خيرا حفظكم الله و رعاكم

السلام عليكم و لاثراء الموضوع يمكن ان نختار من Array مربعات السرد التي نريدها بالطريقة التالية Private Sub UserForm_Initialize() '---------------------------------------------------------------- Art = Array("ComboBox1", "ComboBox4", "ComboBox8") ' هنا نضع ما نريد من مربعات السرد كمبوبكس '---------------------------------------------------------------- For i = 0 To UBound(Art) Me.Controls(Art(i)).List = ws.Range("List").Value Next End Sub

السلام عليكم استعمل هذا الكود Private Sub UserForm_Initialize() For i = 1 To 10 Me.Controls("ComboBox" & i).List = ws.Range("List1").Value Next End Sub

السلام عليكم الملف محمى و يجب ازالة الحماية حتى تستطيع تفعيل هذه القائمة

الحمد لله

السلام عليكم جرب هذا الكود Sub sDelete() LR = ورقة2.[B1000].End(xlUp).Row For i = LR To 4 Step -1 If ورقة.Cells(i, 2) = ورقة1.Range("D3") Then ورقة2.Rows(i).Delete Shift:=xlUp End If Next End Sub

السلام عليكم اخي كل ما في الامر انني اوقفت السطر Call hben و ذلك بوضع العلامة ( ' ) قبله

السلام عليكم الصف الاول_.rar

السلام عليكم فورم معدل.rar

السلام عليكم بعد اذن اخي عبد الله قمت بمحاولة لا ادري مدى صحتها تقوم بفتح الملف ( نتائج وشهادات سادس ) و هناك زر يقوم بنقل الناجح الى شيت مسمى Archive حفظ.rar

السلام عليكم اغلب الضن ان الملف بصيغة 2007 او اكثر و انت تحاول فتحه بصيغة 2003

ثم تعديل الملف في المشاركة 2 ليتم تعديل و حفظ البيانات

اخر جرب المرفق قاعدة بيانات2.rar

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

العفو اخي عطاء الله ارجو منك ان تقوم بتغيير الكود السابق في المشاركة رقم 15 بهذا الكود و اخبرني بالنتيجة Sub sFindddd() m = 4 Application.ScreenUpdating = False With Sheets("ÇáÚãáÇÁ") last = .Cells(Rows.Count, "B").End(xlUp).Row Dim RngB As Range Set RngB = .Range("E4:E" & last) For x = 4 To last If Application.WorksheetFunction.CountIf(RngB, .Cells(x, "B")) = 0 Then .Cells(m, "H") = .Cells(x, "B") .Cells(m, "I") = .Cells(x, "B").Offset(0, 1) m = m + 1 End If Next x End With End Sub

هذا هو الملف الذي ارسلته في المشاركة رقم 11 العملاء.rar

السلام عليكم اخي ياسر جرب الكود التالي و اخبرني هل النتائج صحيحة او لا انسخ الكود كما هو و اربطه بزر و ان كان هناك خطأ اخبرني اين هو Sub NNNNNNNNN() m = 4 Application.ScreenUpdating = False With Sheets("العملاء") last = .Cells(Rows.Count, "B").End(xlUp).Row Dim RngB As Range Set RngB = .Range("B4:B" & last) For x = 4 To last If Application.WorksheetFunction.CountIf(RngB, .Cells(x, "E")) = 0 Then .Cells(m, "H") = .Cells(x, "B") .Cells(m, "I") = .Cells(x, "B").Offset(0, 1) m = m + 1 End If Next x End With End Sub

لا يوجد مرفق

رغم انني لم استوعب المطلوب كما ينبغي لكن جرب هذا الكود Sub sFind() Dim R As Long, x As Long, i As Long Application.ScreenUpdating = False With Sheets("Sheet1") R = .Cells(Rows.Count, "B").End(xlUp).Row x = 3 For i = 4 To R If Application.WorksheetFunction.CountIf(.Range("B4:C" & R), .Cells(i, 3)) = 1 Then x = x + 1 .Cells(x, "D") = .Cells(i, 2) End If Next End With Application.ScreenUpdating = True End Sub

المرفق بعد التعديل aburaji9.rar

جرب هذه المعادلة في الخلية B22 =IF(B22>=100;B22*2;IF(AND(B22>=90;B22<=99);B22*1.5;""))

السلام عليكم لا يوجد مرفق الخطأ في تسمية الاوراق Private Sub Worksheet_Change(ByVal Target As Range) Last_Row = sheet2.Cells(Rows.Count, "D").End(xlUp).Row + 1 LastRow = sheet3.Cells(Rows.Count, "D").End(xlUp).Row + 1 If Not IsEmpty(Target) Then If Target.Column = 3 Then Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 3)).Copy sheet2.Cells(Last_Row, 1) Else If Target.Column = 4 Then Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 4)).Copy sheet3.Cells(LastRow, 1) End If End If End If End Sub

استعمل هذه الكود Private Sub Worksheet_Change(ByVal Target As Range) Last_Row = ورقة2.Cells(Rows.Count, "D").End(xlUp).Row + 1 LastRow = ورقة3.Cells(Rows.Count, "D").End(xlUp).Row + 1 If Not IsEmpty(Target) Then If Target.Column = 3 Then Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 3)).Copy ورقة2.Cells(Last_Row, 1) Else If Target.Column = 4 Then Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 4)).Copy ورقة3.Cells(LastRow, 1) End If End If End If End Sub

السلام عليكم اخي ريان جرب المرفق فورم.rar

السلام عليكم بعد ان انجزت الملف وجدت ان اخي عبد الله قد قام بالمهمة قبلي فجزاه الله خيرا و لاثراء الموضوع فقط ارفقت الملف حسابات 2013-12-4 _34.rar