احمد عبد الناصر

السلام عليكم معذرة علي التأخر في الرد عندي سؤال : هل ان كان قيمة G=190 اي المدي من 160 الي 220 و القيمة المراد معاجتها هي 220 هل تعتبر داخل المدى و نتجاوزها او تعتبر خارج المدي و نضع up (في هذه الحالة up+) تحياتي

السلام عليكم اسعد الله وقاتكم زيادة في الخير هذه طريقة اخرى تحياتي filldown+.rar

السلام عليكم اسعد الله اوقاتكم هذه محاولة لما فهمته من شرحك , لكن النتيجة مختلفة قليلا عن نتيجتك اليدوية .(فمثلا ان افترضت قيمة G ب 210 و المفترض 220 ) 100+(30*4) ارجو ان تراجع الحل و ان كان ما تريد اكمله لك بجزئية الكومنتات و باقي ال steps . تحياتي sttp +.rar

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

السلام عليكم استاذ هاني عدلي الف مبروك على الترقية المستحقة , زادك الله علما و نفع بك . و الشكر موصول لاستاذ عبد الله باقشير و الادارة . تقبل خالص تحياتي

استاذ عبدالله باقشير كل عام وانتم و كل اسرة المنتدى بخير . غفر الله لنا و لكم و لجميع المسلمين.

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

شكرا لك استاذ دغيدي , تقبل خالص تحياتي

لكي تعمل دالة Lookup بدقة يجب ان تكون البيانات مرتبة Sort .

السلام عليكم جرب هذه تحياتي look up+.rar

حمدا لله معذرة فليس لي خبرة في عممليات الطباعة و اكوادها . جرب هذا الكود list.Font.Size = 18 تحياتي

السلام عليكم بدل الكود السابق بهذا و اعلمني بالنتيجة Private Sub cmd_Click() Dim t1, t2, y, x, c, f, t, tt, i list.Clear If txt1.Text <> "" Then t1 = WorksheetFunction.CountIf(Range("b12:b" & Range("b" & Rows.Count).End(xlUp).Row), txt1.Text) If txt2.Text <> "" Then t2 = WorksheetFunction.CountIf(Range("d12:d" & Range("b" & Rows.Count).End(xlUp).Row), "*" & txt2.Text & "*") If t1 + t2 > 0 Then t = IIf(t1 > t2, t1, t2) Dim arr() ReDim arr(1 To 8, 1 To t + 1) For y = 1 To 8 arr(y, 1) = Range("a7").Offset(0, y - 1) Next If txt1.Text <> "" Then If txt2.Text <> "" Then With Range("b:b") Set c = .Find(txt1.Text, LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then f = c.Address Do If InStr(c.Offset(0, 2), txt2.Text) > 0 Then For y = 1 To 8 arr(y, x + 2) = c.Offset(0, y - 2) Next x = x + 1 End If Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> f End If End With Else With Range("b:b") Set c = .Find(txt1.Text, LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then f = c.Address Do For y = 1 To 8 arr(y, x + 2) = c.Offset(0, y - 2) Next x = x + 1 Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> f End If End With End If Else With Range("d:d") Set c = .Find(txt2.Text, LookIn:=xlValues, lookat:=xlPart) If Not c Is Nothing Then f = c.Address Do For y = 1 To 8 arr(y, x + 2) = c.Offset(0, y - 4) Next x = x + 1 Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> f End If End With End If ReDim Preserve arr(1 To 8, 1 To x + 1) list.Column = arr End If End Sub تحياتي

السلام عليكم استاذ حسام , معذرة علي التأخر في الرد تحياتي لاستاذ ضاحي جرب هذه المحاولة https://dl.dropboxusercontent.com/u/44618320/8-6-2013%D9%86%D9%81%D9%82%D9%87%20%D8%A7%D8%AE%D8%B1%20%D8%A7%D9%84%D8%AA%D8%AD%D8%AF%D9%8A%D8%AB_%D9%85%D8%B9%D8%AF%D9%842.rar

السلام عليكم بالنسبة للسؤال الاول جرب هذه الصيغة بفرض ان XXX هو المتغير MainDataBase.Range ("AS4:CZ" & XXX) بالنسبة للسؤال الثاني فلا علم لي به تحياتي

السلام عليكم تحياتي للجميع جرب هذه المحاولة Book2+.rar

السلام عليكم استاذ محمد مصطفى خالص التهاني علي الترقية , رفع الله قدركم و اعلى نزلكم في جنات النعيم

حمدا لله و لا تتردد في اي استفسار مستقبلا حاول متابعة سلسلة استاذ حمادة عمر (سلسلة خطوة ب خطوة ) ستوفر عليك الكثير مسقبلا في فهم الاكواد . تقبل خالص تحياتي

اسعدني مرورك الكريم استاذ سعد , تقبل تحياتي

السلام عليكم اخي الكريم , جرب بدل الاكواد السابقة بهذه الاكواد و اخبرني بالنتيجة . Private Sub CommandButton20_Click() ListBox1.Clear If TextBox35.Text <> "" Then ListBox1.ColumnCount = 2 ListBox1.ColumnWidths = "100;0" If Application.WorksheetFunction.CountIf(Range("C2:c" & Range("c" & Rows.Count).End(xlUp).Row), "*" & TextBox35.Text & "*") > 0 Then Application.ScreenUpdating = False Dim arr() Range("C2:c" & Range("c" & Rows.Count).End(xlUp).Row).AutoFilter Field:=1, Criteria1:="=*" & TextBox35.Text & "*" ReDim arr(1 To 2, 1 To Range("C2:c" & Range("c" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Cells.Count) For Each c In Range("C3:c" & Range("c" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible) arr(1, x + 1) = c.Value arr(2, x + 1) = c.Row x = x + 1 Next [a1].AutoFilter Application.ScreenUpdating = True ListBox1.Column = arr End If End If End Sub Private Sub CommandButton21_Click() ListBox1.Clear If TextBox33.Text <> "" Then ListBox1.ColumnCount = 2 ListBox1.ColumnWidths = "100;0" If Application.WorksheetFunction.CountIf(Range("C2:c" & Range("c" & Rows.Count).End(xlUp).Row), TextBox33.Text & "*") > 0 Then Application.ScreenUpdating = False Dim arr() Range("C2:c" & Range("c" & Rows.Count).End(xlUp).Row).AutoFilter Field:=1, Criteria1:="=" & TextBox33.Text & "*" ReDim arr(1 To 2, 1 To Range("C2:c" & Range("c" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Cells.Count) For Each c In Range("C3:c" & Range("c" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible) arr(1, x + 1) = c.Value arr(2, x + 1) = c.Row x = x + 1 Next [a1].AutoFilter Application.ScreenUpdating = True ListBox1.Column = arr End If End If End Sub Private Sub ListBox1_Click() i = ListBox1.List(ListBox1.ListIndex, 1) For R = 1 To 10 Me.Controls("TextBox" & R).Value = Sheet1.Cells(i, R).Value Next End Sub Private Sub CommandButton19_Click() i = ListBox1.List(ListBox1.ListIndex, 1) Cells(i, 1).Select sama = MsgBox("åá ÊÑíÏ ÇáÐåÇÈ ááÇÓã ÇáãÍÏÏ ÇáÐí ÞãÊ ÈÇÎÊíÇÑå", vbYesNo, "ÑÓÇáÉ ÊÃßíÏ") If sama = vbYes Then UserForm1.Hide Else Exit Sub End If End Sub تحياتي

شكرا على مرورك الكريم ,جعله الله فى ميزان حسناتك وزادك علماً وبركه وعافية شكرا علي مرورك الكريم , تقبل تحياتي

حمدا لله بالنسبة للشرح اول و اخر سطر لتسريع عمل الكود Application.ScreenUpdating = False Application.ScreenUpdating = True هذا السطر يقوم بوضع المعادلة في المدي c2:cx2501 Range("c2:cx2501").FormulaR1C1 = "=IF(sumif(CustmerInvoice!R2C2:R1048576C2,CustmerDataBase!RC1,CustmerInvoice!R2C[1]:R1048576C[1])>0,1,0)" و اخيرا هذا السطر يحول الخلايا الي قيم بدل من المعادلات ليصبح الشيت اسرع و اقل في الحجم Range("c2:cx2501") = Range("c2:cx2501").Value تحياتي

السلام عليكم جرب هذه Sub Dahmour() Application.ScreenUpdating = False Range("c2:cx2501").FormulaR1C1 = "=IF(sumif(CustmerInvoice!R2C2:R1048576C2,CustmerDataBase!RC1,CustmerInvoice!R2C[1]:R1048576C[1])>0,1,0)" Range("c2:cx2501") = Range("c2:cx2501").Value Application.ScreenUpdating = True End Sub تحياتي

جرب الملف المرفق فيه بعض البيانات الوهمية ,فهل هذه هي النتيجة التي تريد ؟ يقوم بكامل العمل و حده و لا يحتاج الي اي شيء , لكنه في الاساس يعتمد نفس طريقة المعادلة فان لم تكن المعادلة تؤدي الغرض فلن يفعل الكود . تحياتي الفكرة باختصار+.rar

السلام عليكم هذا بالنسبة لاول طلب جرب المرفق تحياتي Daily Att.(20130505_0316)+.rar

السلام عليكم استاذ سراب , جرب بدل الاكواد السابقة بهذه الاكواد . ملاحظة : ما زال بطيء نسبيا عند البحث (اعتقد لو استخدم find سيصبح اسرع من loop ) و لكنه اصبح سريع جدا عند الاختيار من الليست بوكس بعد البحث . Private Sub CommandButton20_Click() If TextBox35.Text <> "" Then ListBox1.Clear ListBox1.ColumnCount = 2 ListBox1.ColumnWidths = "100;0" lastrow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row For T = 3 To lastrow If InStr(Sheet1.Cells(T, 3).Text, TextBox35.Text) > 0 Then ListBox1.AddItem ListBox1.List(ListBox1.ListCount - 1, 0) = Sheet1.Cells(T, 3) ListBox1.List(ListBox1.ListCount - 1, 1) = Sheet1.Cells(T, 3).Row End If Next End If End Sub Private Sub ListBox1_Change() i = ListBox1.List(ListBox1.ListIndex, 1) For R = 1 To 10 Me.Controls("TextBox" & R).Value = Sheet1.Cells(i, R).Value Next End Sub تحياتي