يرجى تعديل زر الحذف والتعديل في اليوزرفورم

[Alaaq3]

السلام عليكم ورحمة الله وبركاته وكل عام وانتم بألف خير / اخواني الاعزاء هذا (اليوزر فورم) المرفق من برمجة الاخت الفاضلة ساجدة العزاوي وتم تعديله من قبل الاخ (العيدروس) ليصبح يبحث في كل الشيتات .

طلبي هو  التعديل على زر الحذف والتعديل جزاكم الله الف خير

يرجى تعديل كود الحذف والتعديل.xlsm

[حسين مامون]

اليك الملف

يعمل عندي بكفاءة

يرجى تعديل كود الحذف والتعديل.xlsm

[Alaaq3]

الملف لايفتج عندي ممكن ارسال الكود بالكامل

 

[حسين مامون]

هذا هو الكود كما ارسلته سابقا

ولكن يجب اضافة ليبل للفورم وسميه "Label33"

Private Sub CommandButton1_Click()
Dim lr, i, j
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(3).Row
For i = 2 To lr
    If Label33.Caption = Cells(i, 1).Row Then
        For j = 1 To 26
        
       Cells(i, j) = Controls("TextBox" & j).Text
        Next j
        Exit For
    End If
Next i
Application.ScreenUpdating = False

End Sub

 

[Alaaq3]

للاسف لايعمل . ارجو نسح وارسال كل الكود (اقد كود اليوزرفورم كله) ربما هنالك اختلاف في شي ما

 

[حسين مامون]

 Dim r As Integer

Private Sub CommandButton1_Click()
Dim lr, i, j
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(3).Row
For i = 2 To lr
    If Label33.Caption = Cells(i, 1).Row Then
        For j = 1 To 26
        
       Cells(i, j) = Controls("TextBox" & j).Text
        Next j
        Exit For
    End If
Next i
Application.ScreenUpdating = False

End Sub

Private Sub CommandButton3_Click()
If TextBox7.Value = "" Then
MsgBox "áÇÊæÌÏ ÈíÇäÇÊ ááÍÐÝ", vbCritical, "ÊäÈíå"
Exit Sub
End If
If MsgBox("ÓíÊã ÇáÍÐÝ åá ãÊÃßÏ¿", vbQuestion + vbYesNo) = vbYes Then
  lro = Sheets(ComboBox1.Value).Cells(Rows.Count, 7).End(xlUp).Row
   Set m = Sheets(1).Range("A" & r & ":A" & lro)
   For Each cell In m
   cell.Value = cell.Value - 1
   Next
   
   
  Sheets(ComboBox1.Value).Cells(r, 1).Resize(, 55).Delete shift:=xlUp
       MsgBox "ÊãÊ ÚãáíÉ ÇáÍÐÝ ÈäÌÇÍ"
   For y = 1 To 55
   Controls("textbox" & y).Text = ""
   Next y
   ListBox1.Clear
   UserForm_Activate
   TextBox100 = ""
   End If
   
   TextBox1.Value = Application.WorksheetFunction.Max(Sheets(ComboBox2.Value).Range("A2:A10000")) + 1
TextBox2.SetFocus
End Sub

Private Sub CommandButton4_Click()
TextBox100.Value = ""
ListBox1.Clear
End Sub

Private Sub ListBox1_Click()

For i = 0 To ListBox1.ListCount
    If ListBox1.Selected(i) = True Then
        For j = 1 To 26
        Controls("TextBox" & j).Text = Sheets(ListBox1.List(i, 1)).Cells(ListBox1.List(i, 2), j)
        Label33.Caption = Sheets(ListBox1.List(i, 1)).Cells(ListBox1.List(i, 2), j).Row
        Next j
        r = ListBox1.List(i, 2)
        
        Exit For
    End If
Next i
End Sub


Private Sub TextBox1_Change()

End Sub

Private Sub TextBox2_Change()

End Sub

Private Sub TextBox27_Change()

If TextBox27.Value <> "" Then
ListBox1.Visible = True
Else
ListBox1.Visible = False
End If

Dim x As Worksheet
Dim c As Range
ListBox1.Clear
k = 0
    For i = 1 To 26
            Controls("TextBox" & i).Text = ""
    Next i

    If TextBox27 = "" Then Exit Sub
   
    
  
 For Each x In ThisWorkbook.Worksheets
SS = x.Cells(Rows.Count, 2).End(xlUp).Row
For Each c In x.Range("B2:B" & SS)
b = InStr(c, TextBox27)
If Trim(c) Like "*" & TextBox27 & "*" Then
ListBox1.AddItem
ListBox1.List(k, 0) = x.Cells(c.Row, 2)
ListBox1.List(k, 1) = c.Worksheet.Name
ListBox1.List(k, 2) = c.Row
k = k + 1
End If
Next c
Next x
End Sub

Private Sub TextBox5_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
TextBox27.Value = ""
ListBox1.Clear
End Sub

 

[حسين مامون]

هذه صورة عم رقم 1 قبل التعديل 

وهذه بعد التعيل

 

 

 

 

[Alaaq3]

الآن يعمل . ولكن يقوم بتعديل الاسم المراد تعديله وكذلك يقوم بتعديل اسم ثاني في الورقة الثاني بنفس رقم الرو

[حسين مامون]

الكود يعمل فقط على الشيت النشط 

يمكنك تعديله باضافة with activesheet في بداية الكود  و end with t في اخره مع اصافة نقطة لبداية السطور لي تبدأ ب cells

Dim lr, i, j
With ActiveSheet
Application.ScreenUpdating = False
lr = .Cells(Rows.Count, 1).End(3).Row
For i = 2 To lr
    If Label33.Caption = .Cells(i, 1).Row Then
        For j = 1 To 26
        
       .Cells(i, j) = Controls("TextBox" & j).Text
        Next j
        Exit For
    End If
Next i
Application.ScreenUpdating = False
End With

 

[Alaaq3]

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

[حسين مامون]

وهل جميع الشيتات متشابهة؟

يعني في نفس الرو يوجد نفس الاسم  حتى لو كانت اكثر من 100 شيت ؟

 

[Alaaq3]

لا . وانما اقصد يقوم بالتعديل على البيانات بغض النظر عن كون الشيت اكتف او غير اكتف . مثلا اريد التعديل على اسم معين في احد الشيتات يقوم بالتعديل حتى لو كان الشيت الذي يحتوي على الاسم غير اكتف 

 

[حسين مامون]

جرب المرفق

زر تعديل يقوم بتعديل في جميع الشيتات بناء على الاسم المختار في ليستبوكس

تحياتي

يرجى تعديل كود الحذف والتعديل (1).xlsm

[حسين مامون]

تفضل

يرجى تعديل كود الحذف والتعديل (1).xlsm

[Alaaq3]

اخي العزيز اسف يبدو انك لم تعرف ماذا اريد؟ . اخي الكريم انا اريد ان يغير الاسم الذي اريده في شيت معين وليس تغيير اكثر من اسم في شيتات اخرى

اخي العزيز : اسف ع الإطالة ولكن الكود يقوم بتغيير الاسماء المتشابة  في الشيت الآخر وهذا لا اريده (  انا اريد ان يقوم بتغيير اسم واحد فقط )

[Alaaq3]

اخي الكريم : ليس هنالك شرط في الموضوع . مجرد بحث عن اسم معين وإجراء التعديل عليه فقط دون المساس بالاسماء المتشابهة معه

[حسين مامون]

 لا يمكن التعديل بدون شرط  والا كيف يمكن للكود ان يجد البيان  المختار ضمن مئات البيانات؟

عموما  الشرط  هنا هو رقم الرو  

اختر شيت في الكومبوبوكس ثم عدل ما تريد واضغط زر العديل

 

يرجى تعديل كود الحذف والتعديل (1).xlsm

[حسين مامون]

تفضل

اتمنى ان يكون ما تريد

تحياتي

يرجى تعديل كود الحذف والتعديل (1).xlsm

[حسين مامون]

جرب ورد

يرجى تعديل كود الحذف والتعديل (1).xlsm

[Alaaq3]

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

[حسين مامون]

تفضل

يرجى تعديل كود الحذف والتعديل (1).xlsm

[Alaaq3]

بارك الله بك اخي العزيز . الكود ممتاز و يعمل بصورة جيدة . جزاك الله الف خير وفي ميزان حسناتك ان شاء الله