الصفتى

شكرا استاذ محمد لاهتمام حضرتك و جزاك الله خيرا

السلام عليكم لابد من بدء المشاركة بالتحية !!!يعمل هذا الكود بشكل جيد في البحث فى الليست بوكس ، ولكن عند تجربة سيناريوهين ، يحدث ما يلي: 1) عند استبدال سطر (myCols = Array (1، 3،4، 5، 7، 10) بى myCols = Array (TextBox 2) والسماح لـ TextBox 2 بالكتابة بالداخل إنه (1،3،4،5،7،10) يعطيني رسالة خطأ (application defined or object defined error يتم تمييزه في السطر التالي في الكود (a (ii 1 ، j) = ws.Cells ( i، myCols (ii)). value). ما هو الحل لهذا التحدي؟ 2) عند استبدال سطر (myCols = Array (1، 3،4، 5، 7، 10) بى myCols = Array (T1، T2،T3، T4، T5، T6) حيث T صناديق نص تحتوي على أرقام أعمدة منفصلة يعطى نتيجة صحيحة و لكن عند وجود تكست بوكس منهم فارغ فانه يعطينى رسالة خطا MISMATCH , و يعلم على السطر التالى بالكود code (a (ii 1، j) = ws.Cells (i، myCols (ii)). Value) ما هو الحل لهذا التحدي؟ listbox dynamic.xlsb

Dim rng1 As Range, str_search As String, row_number As Long, n As Long str_search = TextBox45.Value Set rng1 = ThisWorkbook.Sheets("data").Range("a:a").Find(str_search, , xlValues, xlWhole) If Not rng1 Is Nothing Then row_number = rng1.Row Application.ScreenUpdating = False For n = 46 To 321 Me.Controls("TextBox" & n).Value = ThisWorkbook.Sheets("data").Cells(row_number, n).Value Next n For n = 324 To 337 Me.Controls("TextBox" & n).Value = ThisWorkbook.Sheets("data").Cells(row_number, n).Value Next n Application.ScreenUpdating = True End If

السلام عليكم و رحمة الله كل عام و انتم بخير لدى هذا الكود لفلترة الليست بوكس باستخدام "checkbox" و باستخدام "combobox" و هو يعمل جيدا فى حالة ان يكون هناك اختيار فى "combobox" اما فى حالة عدم وجود اختيار فى"combobox" فانه لا يعمل فلترة ب"checkbox" فهل يمكن تعديله لكى يعمل فى كلتا الاحوال و شكرا جزيلا On Error Resume Next Dim aTB() As Variant, bTB As Variant Dim c As Integer, i As Integer c = 0 For i = 7 To 12 If Me("CheckBox" & i).Value = True Then ReDim Preserve aTB(c) aTB(c) = Me("CheckBox" & i).Caption c = c + 1 End If Next If Not Not aTB Then With ListBox2 For i = .ListCount - 1 To 0 Step -1 bTB = Filter(aTB, .List(i, 2), , vbTextCompare) If .List(i, 2) = "" Or UBound(bTB) < 0 Then .RemoveItem (i) Next End With End If If Len(Trim(Me.ComboBox2)) > 0 Then ReDim Preserve aTB(c) aTB(c) = Me.ComboBox2.Value c = c + 1 End If If Not Not aTB Then With ListBox2 For i = .ListCount - 1 To 0 Step -1 bTB = Filter(aTB, .List(i, 3), , vbTextCompare) If .List(i, 3) = "" Or UBound(bTB) < 0 Then .RemoveItem (i) Next End With End If test - Copy.xlsb

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

جزاكم الله خيرا و نفع بكم

شكر ا لكم اساتذتنا الكرام و لقد وجدت حل ثالث و هو Dim M As Long Dim Sum As Double Sum = 0 With Listfind For M = 0 To Listfind .ListCount - 1 If CDbl(Listfind .List(M,10)) > 0 Then Sum = Sum + Listfind .List(M,10) Next M End With UserForm1.TextBox6.Value = Sum

السادة الخبراء الافاضل ارغب فى كود لجمع الارقام الموجبة فقط فى عمود من قائمة listbox واظهار الناتج في خانة textbox

جزاك الله خيرا

UP

Dim x, ws As Worksheet, i As Long, j As Long, lastRow As Long With Me.ListBox1 .Clear .ColumnCount = 7 .ColumnWidths = "60 pt;150 pt;80 pt;150 pt;100 pt;70 pt;100 pt" .ColumnHeads = 0 Set ws = Sheets("Ledger") x = Application.Match(ComboBox1.Value, ws.Rows(1), 0) If Not IsError(x) Then lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row For i = 1 To lastRow If TextBox1 <> "" And InStr(ws.Cells(i, x), TextBox1) <> 0 Then .AddItem .List(j, 0) = ws.Cells(i, 1) .List(j, 1) = ws.Cells(i, 3) .List(j, 2) = ws.Cells(i, 4) .List(j, 3) = ws.Cells(i, 16) .List(j, 4) = ws.Cells(i, 17) .List(j, 5) = ws.Cells(i, 18) .List(j, 6) = ws.Cells(i, 10) j = j + 1 End If Next i End If End With المطلوب عند البحث باسخدام الكمبوبوكس و التكست بوكس يتم اظهار النتائج الموجوده فى شيت ليدجر فى النطاق من (a4:s ) و لكم جزيل الشكر test.xlsb

استاذى الفاضل هل ممكن تعديل الكود بحيث يظهر كل الاعمدة الموجوده فى الليدجر من a : s

Dim i As Integer Dim ListCount1 As Integer ListCount1 = ListBox1.ListCount - 1 If TextBox3.Value <> "" Or TextBox4.Value <> "" Or TextBox5.Value <> "" Or TextBox6.Value <> "" Or TextBox7.Value <> "" Then For i = ListCount1 To 0 Step -1 If InStr(1, ListBox1.List(i, 3), TextBox3) = 0 Then ListBox1.RemoveItem (i) If InStr(1, ListBox1.List(i, 3), TextBox4) = 0 Then ListBox1.RemoveItem (i) If InStr(1, ListBox1.List(i, 3), TextBox5) = 0 Then ListBox1.RemoveItem (i) If InStr(1, ListBox1.List(i, 3), TextBox6) = 0 Then ListBox1.RemoveItem (i) If InStr(1, ListBox1.List(i, 3), TextBox7) = 0 Then ListBox1.RemoveItem (i) Next i End If او مساعدتى فى تصحيح هذا الكود ان كان يفى بالمطلوب

السادة الخبراء الافاضل لقد وصلت لهذا الكود و لكنه لا يعمل بالشكل المطلوب هل ممكن المساعده فى تعديله ليؤدى الغرض Dim i As Integer Dim ListCount1 As Integer ListCount1 = ListBox1.ListCount - 1 If TextBox3.Value <> "" Or TextBox4.Value <> "" Or TextBox5.Value <> "" Or TextBox6.Value <> "" Or TextBox7.Value <> "" Then For i = ListCount1 To 0 Step -1 If InStr(1, ListBox1.List(i, 3), TextBox3) = 0 Or InStr(1, ListBox1.List(i, 3), TextBox4) = 0 Or InStr(1, ListBox1.List(i, 3), TextBox5) = 0 Or InStr(1, ListBox1.List(i, 3), TextBox6) Or InStr(1, ListBox1.List(i, 3), TextBox7) = 0 Then ListBox1.RemoveItem (i) End If Next i End If الملاحظات عليه : اذا اخترت اسم العميل من الكمبوبكس و كتبت حرف الف فى البحث ثم قمت باختيار اى تشيك بوكس و الضغط على على زر التصفية فقد لاحظت الاتى و لا اعرف السبب اولا : لا تعمل التصفية اذا اخترت اى تشيك بوكس الا اذا كان معه تشيك بوكس 4(علمية) فيتم التصفية مضبوط و لكن بدون اختيار تشيك بوكس4 معه فلا تعمل، ثانيا : اذا اخترت تشيك بوكس 4 فقط لوحده فانه يفلتر و لكن ياتى بجميع البيانات ما عدى ما يدل عليه تشيك بوكس 4(علمية) ثالثا : و ده مهم جدا انى ارغب فى ان التصفية تعمل باى اختيار منفرد او متعدد و اسف على الاطالة و لكم جزيل الشكر مرفق ملف معدل به الفورمتجربة (1).xlsb

تجربة (1).xlsb الساده الخبراء الافاضل برجاء المساعدة Dim i As Integer Dim ListCount1 As Integer ListCount1 = ListBox1.ListCount - 1 If TextBox3.Value <> "" Then For i = ListCount1 To 0 Step -1 If InStr(1, ListBox1.List(i, 3), TextBox3) = 0 Then ListBox1.RemoveItem (i) End If Next i End If كود التصفية يعمل على تصفية البيانات فى الليست بوكس وفقا للمكتوب فى تكست بوكس3 هل ممكن تعديل الكود وعمل كودين الاول ان يتم التصفية وفقا للمكتوب فى تكست بوكس 3 و تكست بوكس 4 معا الكود الثانى ان يتم تصفية البيانات بدون المكتوب فى تكست بوكس 3 و تكست بوكس 4 او ان امكن ان يكون التصفية بناء على checkbox3& checkbox2 & checkbox1

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

استاذى الفاضل بفرض عمود 6 و 7 بالليست بوكس تحتوى على ارقام هل يوجد كود يضيف عمود جديد بالليست بوكس فرضا عمود 8 و بقوم بطرح عمود 6 - عمود 7 و شاكرا لك سعة صدرك

بارك الله فيك و جعلك عونا للسائلين ، جزاك الله خيرا

الساده الافاضل هل يمكن تحويل كود البحث المرفق فى النموذج و احضار البيانات من اعمدة غير منتظمة وفقا لتكست بوكس1 الى احضار نفس البيانات و لكن وفقا لكومبوبوكس و تكست بوكس 1 معا Public Sub CMDSEARCH_Click() ListBox1.CLEAR ListBox1.ColumnCount = 7 ListBox1.ColumnWidths = "60 pt;150 pt;80 pt;150 pt;100 pt;70 pt;100 pt" ListBox1.ColumnHeads = 0 Dim ws As Worksheet, i As Long, i2 As Long Set ws = Sheets("ليدجر") Dim lastrow As Long lastrow = ws.Cells(Rows.Count, "b").End(xlUp).Row For i = 1 To lastrow If TextBox1 <> "" And InStr(ws.Cells(i, 3), TextBox1) <> 0 Then ListBox1.AddItem ListBox1.List(i2, 0) = ws.Cells(i, 1) ListBox1.List(i2, 1) = ws.Cells(i, 3) ListBox1.List(i2, 2) = ws.Cells(i, 4) ListBox1.List(i2, 3) = ws.Cells(i, 16) ListBox1.List(i2, 4) = ws.Cells(i, 17) ListBox1.List(i2, 5) = ws.Cells(i, 18) ListBox1.List(i2, 6) = ws.Cells(i, 10) i2 = i2 + 1 End If Next i End Sub تجربة (1).xlsb

عاجز عن الشكر لحضرتك

هل بتجربة.xlsbالامكان اضافة كود لعد عدد العملاء فى الليست بوكس و اظهاره فى text box2 شاكرا لكم سعة صدركم

شكرا استاذ محمد الكود يعمل بنجاح جزاك الله خيرا

' ليدجر - حجوزات ترحيل Dim answer As Integer answer = MsgBox("ترغب فى ادخال هذه البيانات", vbQuestion + vbYesNo + vbDefaultButton2, "Confirmation") If answer = vbYes Then If Txt3 <> "" Then Dim rng1 As Range Dim str_search As String str_search = Txt3.Value Set rng1 = Sheets("ليدجر").Range("E:E").Find(str_search, , xlValues, xlWhole) Application.ScreenUpdating = False Dim row_number As Long row_number = rng1.Row Dim lastcolumn As Long lastcolumn = IIf(Sheets("ليدجر").Range("lu" & row_number) = "", 333, Sheets("ليدجر").Range("lu" & row_number).End(xlToRight).Column + 1) Sheets("ليدجر").Cells(row_number, lastcolumn).Value = C3.Value Sheets("ليدجر").Cells(row_number, lastcolumn + 1).Value = CDate(C4) Sheets("ليدجر").Cells(row_number, lastcolumn + 2).Value = C5.Value Sheets("ليدجر").Cells(row_number, lastcolumn + 3).Value = C6.Value Sheets("ليدجر").Cells(row_number, lastcolumn + 4).Value = C7.Value 'Sheets("ليدجر").Select Cells(row_number, lastcolumn).Select Dim lastrow As Long lastrow = ThisWorkbook.Sheets("حجوزات").Range("D100000").End(xlUp).Row lastrow = lastrow + 1 With ThisWorkbook.Sheets("حجوزات") .Range("H" & lastrow).Value = Txt50.Value .Range("I" & lastrow).Value = Txt3.Value .Range("D" & lastrow).Value = TXT1.Value .Range("G" & lastrow).Value = CDate(TXT2) .Range("F" & lastrow).Value = Txt8.Value .Range("K" & lastrow).Value = Txt18.Value .Range("M" & lastrow).Value = Txt28.Value .Range("N" & lastrow).Value = Txt31.Value 'كود مسح البيانات Me.Txt50.Value = "" Me.Txt3.Value = "" Me.TXT1.Value = "" Me.TXT2.Value = "" Me.Txt8.Value = "" Me.Txt18.Value = "" Me.Txt28.Value = "" Me.Txt31.Value = "" End With End If End If MsgBox "تم الترحيل بنجاح" If Not rng1 Is Nothing Then Dim lastrow As Long lastrow = ThisWorkbook.Sheets("حجوزات").Range("D100000").End(xlUp).Row lastrow = lastrow + 1 With ThisWorkbook.Sheets("حجوزات") .Range("H" & lastrow).Value = Txt50.Value .Range("I" & lastrow).Value = Txt3.Value .Range("D" & lastrow).Value = TXT1.Value .Range("G" & lastrow).Value = CDate(TXT2) .Range("F" & lastrow).Value = Txt8.Value .Range("K" & lastrow).Value = Txt18.Value .Range("M" & lastrow).Value = Txt28.Value .Range("N" & lastrow).Value = Txt31.Value 'كود مسح البيانات Me.Txt50.Value = "" Me.Txt3.Value = "" Me.TXT1.Value = "" Me.TXT2.Value = "" Me.Txt8.Value = "" Me.Txt18.Value = "" Me.Txt28.Value = "" Me.Txt31.Value = "" Application.ScreenUpdating = True End With End If MsgBox "تم الترحيل بنجاح" عايز لو (txt3<>"") يرحل وفقا للكودين للشيتين و ده بيحصل فعلا اللى محتاجه انه لو (txt3="") يرحل الكود التانى فقط لشيت الحجوزات

شكرا جزيلا

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