اذهب الي المحتوي
أوفيسنا

الصفتى

02 الأعضاء
 عرض الملف الشخصي  عرض المشاركات

  • Posts

    96

  • تاريخ الانضمام

  • تاريخ اخر زياره

 نوع المحتوي 

مشاركات المكتوبه بواسطه الصفتى

    المساعدة فى كود البحث فى الليست بوكس

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم لابد من بدء المشاركة بالتحية !!!يعمل هذا الكود بشكل جيد في البحث فى الليست بوكس ، ولكن عند تجربة سيناريوهين ، يحدث ما يلي:

    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

    ممكن المساعدة فى معرفة الخطأ فى كود البحث هذا؟

    في منتدى الاكسيل Excel

    قام بنشر 

    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

     

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

    في منتدى الاكسيل Excel

    قام بنشر

    السلام عليكم و رحمة الله
    كل عام و انتم بخير
    لدى هذا الكود لفلترة الليست بوكس باستخدام "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

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

    في منتدى الاكسيل Excel

    قام بنشر

    شكر ا لكم اساتذتنا الكرام و لقد وجدت حل ثالث و هو 

    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

     

    برجاء تعديل الكود التالى للاستاذ lionheart فى البحث و اظهار البيانات فى الليست بوكس

    في منتدى الاكسيل Excel

    قام بنشر 

        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

    البحث فى ليست بوكس عن طريق تكست بوكس و كمبوبوكس

    في منتدى الاكسيل Excel

    قام بنشر

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

    اقتباس
    في ٢٦‏/٩‏/٢٠٢١ at 07:29, lionheart said: 
    Public Sub CMDSEARCH_Click()
    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
End Sub

     

     

    برجاء المساعده فى كود تصفية لليست بوكس

    في منتدى الاكسيل Excel

    قام بنشر 

    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

    او مساعدتى فى تصحيح هذا الكود ان كان يفى بالمطلوب

    برجاء المساعده فى كود تصفية لليست بوكس

    في منتدى الاكسيل Excel

    قام بنشر

    السادة الخبراء الافاضل

    لقد وصلت لهذا الكود و لكنه لا يعمل بالشكل المطلوب هل ممكن المساعده فى تعديله ليؤدى الغرض 

    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

    برجاء المساعده فى كود تصفية لليست بوكس

    في منتدى الاكسيل Excel

    قام بنشر

    تجربة (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

    البحث فى ليست بوكس عن طريق تكست بوكس و كمبوبوكس

    في منتدى الاكسيل Excel

    قام بنشر

    الساده الافاضل

    هل يمكن تحويل كود البحث المرفق فى النموذج  و احضار البيانات من اعمدة  غير منتظمة وفقا لتكست بوكس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

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

    في منتدى الاكسيل Excel

    قام بنشر 

    ' ليدجر - حجوزات ترحيل
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="") يرحل الكود التانى فقط لشيت الحجوزات

×
×
  • اضف...

Important Information

  I accept