طلب تعديل كود بحت الاخ الكبير salim ليتوفق مع كود الليست بوكس

[ابا اسماعيل]

السلام عليكم ورحمة الله وبركاته

اخواني في الله هذا كود الى الاخ الكبير salim كود بحت رئع جدا
لقد قمت بعدت محوالات لضبط الكود في الملف ولم استطيع اخواني المرجو ضبط الكود ليتوفق مع كود الليست بوكس في ملف العمال وجزاكم الله خيرا

 

 

Private Sub TextBox1_Change()
   ListBox1.Clear
   ListBox1.RowSource = ""
   Dim k#: k = 0
   Dim laste_row#
   Dim All_Rg As Range 'Range when we saecrh
   Dim Fd_Rg As Range  'Range to find
   Dim F_row#, A_row#  'First row by saerch,Actual row by saerch
   With Sheets("data")
    laste_row = .Cells(Rows.Count, 1).End(3).Row
    Set All_Rg = .Range("a5:B" & laste_row)
    Set Fd_Rg = All_Rg.Find(Left(TextBox1.Value, Len(TextBox1.Value)), lookat:=2)
       If Not Fd_Rg Is Nothing Then
          F_row = Fd_Rg.Row: A_row = F_row
            Do
               If Left(Fd_Rg, Len(TextBox1.Value)) = _
                  TextBox1.Value Then
                  ListBox1.AddItem .Cells(F_row, 1)
                  ListBox1.List(k, 1) = .Cells(F_row, 2)
                  k = k + 1
               End If
               Set Fd_Rg = All_Rg.FindNext(Fd_Rg)
                F_row = Fd_Rg.Row
                If F_row = A_row Then Exit Do
            Loop
        End If
   End With
    Me.TextBox_num = k
End Sub

 

فاتورة.xlsm

[سليم حاصبيا]

تم معالجة الأمر بالنسبة (للبحث فقط) والباقي عليك لضيق الوقت

 

ismail.xlsm

[ابا اسماعيل]

السلام عليكم اخي سليم حاصبيا جزاك الله خيرا على اهتمامك بالموضوع

اخي سليم ممكن لوسمحت تعديل الكود ليتوفق  مع كود اللست بوكس دوناالغاء كود ليست بوكس

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

[سليم حاصبيا]

تم التعديل 

خطوات العمل كما في الصورة

1- تكتب في التكست بوكس الحرف(الحروف التي تريدها)
2-تحتار من الليست بوكس الصفوف التي تريدها (باستعمال الــ Ctrl أو Shift )
3- تضغط على الزر Add To sheet

4- عندما يزيد عدد الصقوف (في الشيت) عن العدد 60 يتم التسجيل ابتداء من أول اللائحة (الملف مرفق)

 

ismail_1.xlsm

[ابا اسماعيل]

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

اخي رجاء وليس امرا لو سمحت ممكن ان تقوم بتعديل الكود البحت ليتوافق مع كود الليست بوكس الاول في الملف وجزاك الله خيرا اخي الفاضل

[سليم حاصبيا]

 عذراً

انا لا أعمل في مجال اليوزر وطريقة ترابط 2 يوزر مع بعض لان خبرتي في هذا المجال بسيطة

[ابا اسماعيل]

بوركت جهودك، و كللت أعمالك جزاك الله خيرا

[سليم حاصبيا]

بمكن الاستغناء غن اليوزر الثاني بهذا الكود

1- عند الضغط غلى الزر تظهر  لك رسالة تطلب الكمية (اذا ادخلت بالخطأ نصاُ يبوفف الكود ويطلب عدداً)

2- بعد ادخال العدد المطلوب يقوم الكود بادخال البيانات مع المعادلة المطلوبة

الكود

Private Sub CmdAdd_Click()
 If Me.ListFind.ListCount = 0 _
 Or Me.ListFind.ListIndex < 1 Then Exit Sub
 Dim arr()
 Dim sh As Worksheet
 Dim Ro%, m%, x%, Y%
 Set sh = Sheets("فاتورة")
 Ro = sh.Cells(Rows.Count, "c").End(3).Row
 If Ro < 10 Then Ro = 9
 Ro = Ro + 1
 If Ro > 60 Then
  sh.Range("c10:H60").ClearContents
  Ro = 10
 End If
 x = Me.ListFind.ListIndex
  Y = Application.InputBox("tYPE NUMBER", "CHOOSE ONLY NUMBERS", 1, Type:=2)
  With sh.Cells(Ro, 3)
   .Value = Val(.Offset(-1)) + 1
   .Offset(, 1) = Me.ListFind.List(x, 2)
   .Offset(, 2) = Me.ListFind.List(x, 3)
   .Offset(, 3) = Y
   .Offset(, 4) = Me.ListFind.List(x, 4)
  End With
  With sh.Range("h10:h" & Ro)
   .Formula = "=IF(E10="""","""",PRODUCT(F10:G10))"
   .Value = .Value
  End With
  TextFind_Change
  
End Sub

'+++++++++++++++++++++++++++++++++
Private Sub TextFind_Change()

   ListFind.Clear

   Dim k#: k = 0
   Dim t#
   Dim laste_row#
   Dim All_Rg As Range 'Range when we saecrh
   Dim Fd_Rg As Range  'Range to find
   Dim F_row#, A_row#  'First row by saerch,Actual row by saerch
   With Me.ListFind
       .AddItem "تسلسل"
       .List(.ListCount - 1, 1) = "رقم الصف"
       For k = 2 To .ColumnCount
        .List(.ListCount - 1, k) = Sheets("البيانات").Cells(1, k - 1)
       Next
    End With
    k = 1
   With Sheets("البيانات")
    laste_row = .Cells(Rows.Count, 2).End(3).Row
    Set All_Rg = .Range("B2:B" & laste_row)
    
    Set Fd_Rg = All_Rg.Find(Left(TextFind.Value, Len(TextFind.Value)), lookat:=2)
       If Not Fd_Rg Is Nothing Then
          F_row = Fd_Rg.Row: A_row = F_row
            Do
               If Left(Fd_Rg, Len(TextFind.Value)) = _
                  TextFind.Value Then
                 Me.ListFind.AddItem
                 Me.ListFind.List(Me.ListFind.ListCount - 1, 0) = k
                 Me.ListFind.List(Me.ListFind.ListCount - 1, 1) = F_row
               
                 Me.ListFind.List(Me.ListFind.ListCount - 1, 2) = _
                 .Cells(F_row, 1)
                 Me.ListFind.List(Me.ListFind.ListCount - 1, 3) = _
                 .Cells(F_row, 2)
                 Me.ListFind.List(Me.ListFind.ListCount - 1, 4) = _
                 .Cells(F_row, 3)
                 Me.ListFind.List(Me.ListFind.ListCount - 1, 5) = _
                 .Cells(F_row, 4)
                  k = k + 1
               End If
               Set Fd_Rg = All_Rg.FindNext(Fd_Rg)
                F_row = Fd_Rg.Row
                If F_row = A_row Then Exit Do
            Loop
        End If
   End With
   If Me.ListFind.ListCount = 1 Then
     Me.ListFind.Clear
   End If
End Sub

الملف مرفق

ismail_NEW.xlsm

[ابا اسماعيل]

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