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

[ابو حمادة]

مرفق ملف

TEXT.rarFetching info...

[Ali Mohamed Ali]

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

TEXT.xlsxFetching info...

[abo fars]

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

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

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

 

 

TEXT Salim.xlsx

[ابو حمادة]

  في 19‏/2‏/2018 at 14: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

 

Expand  

 

  في 19‏/2‏/2018 at 17:20, سليم حاصبيا said:

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

الملف مرفق

 

Book1 salim.rarFetching info...

Expand  

 

  في 10‏/10‏/2017 at 13:46, سمير نجار said:

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

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

كود قسمة1.rarFetching info...

Expand  

 

  في 28‏/2‏/2018 at 04:23, سليم حاصبيا said:

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

 

 

TEXT Salim.xlsxFetching info...

Expand  

 

  في 28‏/2‏/2018 at 01:33, ali mohamed ali said:

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

 

TEXT.xlsxFetching info...

Expand  

 

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

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

علما ان الملف الاصلي يحتوي على اكثر من 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

[ابو حمادة]

  في 28‏/2‏/2018 at 13:01, سليم حاصبيا 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.xlsFetching info...

Expand  

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

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

 

  في 28‏/2‏/2018 at 12:30, زيزو العجوز 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

 

Expand  

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

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