كود اذا تطابق الشروط يكتب حرف M

[ابو حمادة]

مرفق ملف

TEXT.rar

[Ali Mohamed Ali]

تفضل جرب هذا بالمعادلات

TEXT.xlsx

[abo fars]

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

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

حل اخر مع قليل من التفاصيل

 

 

TEXT Salim.xlsx

[ابو حمادة]

في ١٩‏/٢‏/٢٠١٨ at 16:08, سليم حاصبيا said:

ريما يكون هذا الكود هو المطلوب

Private Sub UserForm_Initialize()
Dim k%, i%
k = Sheets("ورقة1").Cells(6, Columns.Count).End(1).Column
On Error Resume Next
 For i = 1 To k
  Me.Controls("Lebel" & i).Caption = Sheets("ورقة1").Cells(6, i).Value
  Next

End Sub

 

 

في ١٩‏/٢‏/٢٠١٨ at 19:20, سليم حاصبيا said:

قم بتغيير كافة اسماء  Lebel    من خلال Properties  الى LB2  LB1  ,وهكذا  اذ ربما يكون Lebel1 او Lebe2 غير موجود حقيقة( تم ادراجه ثم مسحه)

الملف مرفق

 

Book1 salim.rar

 

في ١٠‏/١٠‏/٢٠١٧ at 15:46, سمير نجار said:

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

تفضل اخي الكريم ابوحمادة

كود قسمة1.rar

 

منذ ساعه, سليم حاصبيا said:

حل اخر مع قليل من التفاصيل

 

 

TEXT Salim.xlsx

 

4 ساعات مضت, ali mohamed ali said:

تفضل جرب هذا بالمعادلات

 

TEXT.xlsx

 

الف شكر لاساتذتي الاجلاء

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

علما ان الملف الاصلي يحتوي على اكثر من 5 الاف اسم ونظر لتقل حجم الملف اريد كود يعمل المطلوب 

لاخر صف به بيانات

ملحوظه المعدله الاولى للاستاذ علي محمد على

لها مميزاتها 

وايضا المعادلة الثاانيه للاستاذ سليم لها مميزاتها واتمني ان يكون هناك كود يجمع بينهما  ان كنت اريد تسلسلس حرف (m) او لاء 

بالكود 

 

[ابراهيم الحداد]

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

جرب هذا الكود

Sub MSghin()
Dim C As Range
Dim x, y, z
x = Range("G2")
y = Range("F2")
z = Range("H2")
For Each C In Range("B4:B" & Range("B" & Rows.Count).End(xlUp).Row)
If C.Value = x Then
If C.Offset(0, 1) = y Then
If C.Offset(0, 2) = z Then
   C.Offset(0, 7) = "M"
End If
End If
End If
Next
End Sub

 

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

بعد اذن اخي زيزو (مع او بدون ترقيم  حسب الاختيار) 

الكود

Option Explicit
Sub extract_data()
Dim My_Sh As Worksheet: Set My_Sh = Sheets("ورقة1")
Dim s%, Initial_string$, i%: i = 4: s = 1
Dim LrF As Long
Dim x As Boolean
x = My_Sh.Range("j2") = "Yes"
Application.ScreenUpdating = False
With My_Sh
 LrF = .Cells(Rows.Count, "F").End(3).Row
  If LrF < 4 Then LrF = 4
  .Range("f4:F" & LrF).Clear
 Initial_string = .Cells(2, "G") & .Cells(2, "F") & .Cells(2, "H")
 Do Until .Cells(i, 2) = vbNullString
  If .Cells(i, 2) & .Cells(i, 3) & .Cells(i, 4) = Initial_string Then
    With .Cells(i, "F")
    .Value = IIf(x, "M" & s, "M")
     With .Font
      .ColorIndex = 3
      .Bold = True
     End With
    End With
  s = s + 1
End If
   i = i + 1
 Loop
End With
Application.ScreenUpdating = True
End Sub

الملف

 

TEXT Salim1.xls

[ابو حمادة]

8 ساعات مضت, سليم حاصبيا said:

بعد اذن اخي زيزو (مع او بدون ترقيم  حسب الاختيار) 

الكود

Option Explicit
Sub extract_data()
Dim My_Sh As Worksheet: Set My_Sh = Sheets("ورقة1")
Dim s%, Initial_string$, i%: i = 4: s = 1
Dim LrF As Long
Dim x As Boolean
x = My_Sh.Range("j2") = "Yes"
Application.ScreenUpdating = False
With My_Sh
 LrF = .Cells(Rows.Count, "F").End(3).Row
  If LrF < 4 Then LrF = 4
  .Range("f4:F" & LrF).Clear
 Initial_string = .Cells(2, "G") & .Cells(2, "F") & .Cells(2, "H")
 Do Until .Cells(i, 2) = vbNullString
  If .Cells(i, 2) & .Cells(i, 3) & .Cells(i, 4) = Initial_string Then
    With .Cells(i, "F")
    .Value = IIf(x, "M" & s, "M")
     With .Font
      .ColorIndex = 3
      .Bold = True
     End With
    End With
  s = s + 1
End If
   i = i + 1
 Loop
End With
Application.ScreenUpdating = True
End Sub

الملف

 

TEXT Salim1.xls

شكرا استاذي الفاضل على هذا المجهود

اسئل الله العلي العظيم ان يجعله فى ميزان حسناتك

 

9 ساعات مضت, زيزو العجوز said:

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

جرب هذا الكود

Sub MSghin()
Dim C As Range
Dim x, y, z
x = Range("G2")
y = Range("F2")
z = Range("H2")
For Each C In Range("B4:B" & Range("B" & Rows.Count).End(xlUp).Row)
If C.Value = x Then
If C.Offset(0, 1) = y Then
If C.Offset(0, 2) = z Then
   C.Offset(0, 7) = "M"
End If
End If
End If
Next
End Sub

 

شكرا استاذي الفاضل على هذا المجهود

اسئل الله العلي العظيم ان يجعله فى ميزان حسناتك