شرح كود يعمل بطريقة دالة VLOOKUP داخل يوزرفورم

[بن خليفه]

حبايبي ما أحب أطول عليكم ..

أرغب بكتابة في يوزر فورم والخانة الثانية  تعطي البيانات الموجودة

مقابل المدخل في الرقم

 

مرفق يوضح المطلوب

في اليوزر فورم.rar

[طلعت محمد حسن]

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

اخي العزيز شاهد المرفق 

في اليوزر فورم تعديل1.rar

[بن خليفه]

تسلم الله يسعدك ..

 

لكن هناك مشكلة في حال تم وضع أكثر من 800 خلية حيث يأخذ وقت عند كتابة أول رقمين

 

هل توجد طريقة خفيفه وبسيطة 

[طلعت محمد حسن]

اذا كان قصدك كتابة الارقام يمكن عمل ComboBox بالارقام واختيار الرقم منه 

بانتظار ردك

[بن خليفه]

عفواً ..

 

وصلت الان أكثر من 12000 رقم

 

أنا أحتاج أكتب رقم ، يظهر الرمز تلقائياً

 

الطريقة اللي انت وضحتها ممتازة جداً .. لكن بطيئة عند كتابة الرقم

 

وبالنسبة لل ComboBox لا يصلح استخدامه في ادخال بيانات وترحيلها 

[رجب جاويش]

السلام عليكم

بعد أذن أخى الفاض / طلعت محمد

 

أخى الفاضل

جرب الكود التالى

أنا جربته على 15000  صف والسرعة معقولة

Private Sub TextBox1_Change()
On Error Resume Next
Application.ScreenUpdating = False
x = Cells.Find(What:=TextBox1.Value, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Offset(0, 1).Address
Me.TextBox2 = Range(x).Value
Application.ScreenUpdating = True
End Sub

userform.rar

[شوقي ربيع]

السلام عليكم

الشكر موصول للاخوين  طلعت محمد حسن و الاستاد رجب جاويش

لاثراء الموضوع اكثر هذا كود ايضا يفي بالغرض

Private Sub TextBox1_Change()
Dim Lr As Long
Dim i As Double, Mh As Double
 On Error Resume Next
i = Me.TextBox1
Application.ScreenUpdating = False
    With Sheet1
               Lr = .Cells(.Rows.Count, "D").End(xlUp).Row
               Mh = WorksheetFunction.Match(i, .Range("D4:D" & Lr), 0) + 3
    End With
    Me.TextBox2 = Sheet1.Range("E" & Mh)
Application.ScreenUpdating = True
End Sub

[رجب جاويش]

أخى الحبيب / شوقى ربيع

كود ممتاز وسريع

تسلم ايديك

[بن خليفه]

 

السلام عليكم

بعد أذن أخى الفاض / طلعت محمد

 

أخى الفاضل

جرب الكود التالى

أنا جربته على 15000  صف والسرعة معقولة

Private Sub TextBox1_Change()
On Error Resume Next
Application.ScreenUpdating = False
x = Cells.Find(What:=TextBox1.Value, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Offset(0, 1).Address
Me.TextBox2 = Range(x).Value
Application.ScreenUpdating = True
End Sub

 

شكراً يل غالي ..

 

لكن إذا كانت الداتا في الشيت الثاني ؟؟

[بن خليفه]

 

السلام عليكم

الشكر موصول للاخوين  طلعت محمد حسن و الاستاد رجب جاويش

لاثراء الموضوع اكثر هذا كود ايضا يفي بالغرض

Private Sub TextBox1_Change()
Dim Lr As Long
Dim i As Double, Mh As Double
 On Error Resume Next
i = Me.TextBox1
Application.ScreenUpdating = False
    With Sheet1
               Lr = .Cells(.Rows.Count, "D").End(xlUp).Row
               Mh = WorksheetFunction.Match(i, .Range("D4:D" & Lr), 0) + 3
    End With
    Me.TextBox2 = Sheet1.Range("E" & Mh)
Application.ScreenUpdating = True
End Sub

 

ما ضبط معي وخصوصاً في حال إني غيرت الداتا ووضعتها في الشيت الثاني

[رجب جاويش]

أخى الفاضل

هل تريد الداتا فى الشيت الثانى وزر اظهار الفورم معها فى الشيت الثانى أم يظل زر اظهار الفورم كما هو فى الصفحة الأولى

[رجب جاويش]

السلام عليكم

هذا كود آخر أسرع من الأول

Private Sub TextBox1_Change()
On Error Resume Next
TextBox2 = ""
LR = Cells(Rows.Count, 2).End(xlUp).Row
TextBox2 = Application.WorksheetFunction.VLookup(Val(TextBox1), Range("B2:C" & LR), 2, 0)
End Sub

userform2.rar

[بن خليفه]

أخى الفاضل

هل تريد الداتا فى الشيت الثانى وزر اظهار الفورم معها فى الشيت الثانى أم يظل زر اظهار الفورم كما هو فى الصفحة الأولى

 

يبقى الزر في الشيت الأول

[بن خليفه]

 

السلام عليكم

هذا كود آخر أسرع من الأول

Private Sub TextBox1_Change()
On Error Resume Next
TextBox2 = ""
LR = Cells(Rows.Count, 2).End(xlUp).Row
TextBox2 = Application.WorksheetFunction.VLookup(Val(TextBox1), Range("B2:C" & LR), 2, 0)
End Sub

 

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

وفي حال أرغب إضافة أعمده وتظهر في تكست بوكس ثالث ؟؟؟

أعرف إني ثقلت عليكم 

لكم كل الأجر إن شاء الله

تم تعديل مايو 19, 2014 بواسطه بن خليفه

[طلعت محمد حسن]

استاذ رجب ممكن شرح هذه الجزئية من الكود

LR = Cells(Rows.Count, 2).End(xlUp).Row

وخصوصا الرقم 2

وشكرا

[احمد فضيله]

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

بعد اذن كل الاخوه ... جزاهم الله كل خير

لإثراء الموضوع

Private Sub TextBox1_Change()

Dim hh As Integer

For hh = 2 To 10000
If Sheet3.Cells(hh, 2) = Me.TextBox1.Text Then
     Me.TextBox2 = Sheet3.Cells(hh, 3)

End If
Next

End Sub

و مرفق الحل

و الله المستعان

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

FADILA.rar

[بن خليفه]

الان وصلني أكثر من 5 أكواد

 

يا اخوان الله يسعدكم أنا ما فهمت ولا كود

 

تسلموا لي

[عبدالله باقشير]

استاذ رجب ممكن شرح هذه الجزئية من الكود

LR = Cells(Rows.Count, 2).End(xlUp).Row

وخصوصا الرقم 2

وشكرا

 

آخر صف في العمود 2

[بن خليفه]

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

بعد اذن كل الاخوه ... جزاهم الله كل خير

لإثراء الموضوع

Private Sub TextBox1_Change()

Dim hh As Integer

For hh = 2 To 10000
If Sheet3.Cells(hh, 2) = Me.TextBox1.Text Then
     Me.TextBox2 = Sheet3.Cells(hh, 3)

End If
Next

End Sub

و مرفق الحل

و الله المستعان

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

 

عزيزي ..

يعطيك العافية ..

انت شرحته على 2003

ولا جيت أحفظه على 2010 يرفض يعطيني المدخلات

[طلعت محمد حسن]

 

استاذ رجب ممكن شرح هذه الجزئية من الكود

LR = Cells(Rows.Count, 2).End(xlUp).Row

وخصوصا الرقم 2

وشكرا

 

آخر صف في العمود 2

 

شكرا لك يا استاذنا عبد اللة بارك اللة في عمرك

[احمد فضيله]

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

بعد اذن كل الاخوه

المرفق office 2013 بامتداد xlsm

 

و الله المستعان

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

FADILA 2013.rar

[إبراهيم ابوليله]

الاخوه الافاضل

دائما ما يكون الموضوع صاحب الحلول المتنوعه هو الموضوع الاكثر تميزا

والاكثر اثاره وافاده لنا جميعا

بارك الله فيكم جميكم

ووفقكم لفعل الخير ولما يحبه ويرضاه

-----------------------------------------

اسمحو لى ان

اشاركم بكود

اعتقد انه خفيف ايضا فى حالة كثرة البيانات

--------------------------------------------------------------

On Error GoTo 100
       Worksheets("SHEET3").Activate
       Columns(1).Find(TextBox1, MatchCase:=True).Activate
          TextBox2 = ActiveCell.Offset(0, 0).Value
          TextBox3 = ActiveCell.Offset(0, 1).Value
          TextBox4 = ActiveCell.Offset(0, 2).Value