مطلوب كود بحث وترحيل يعني مثل دالة Lookup لكن بالكود

[nash60]

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

اخواني الكرام :

 

اسعد الله مسائكم  مرفق ملف اكسل المطلوب  كود بحث بناءا على متغيرين وليس دالة اريد الحل
بالكود ان تكرمتم

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

 

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

 

Test02.rar

[nash60]

اخواني الرجاء ممن يستطيع المساعدة ان لا يبخل بها بارك الله فيكم

[احمدزمان]

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

 

اخي الفاضل

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

Sub SYMBOOL()
Dim FS As Worksheet, TS As Worksheet
Dim FR, TR, ER1, ER2, Q1, Q2
Set FS = Sheets("Symbol") ' ãä æÑÞÉ
Set TS = Sheets(ActiveSheet.Name) ' Çáì æÑÞÉ
ER1 = FS.UsedRange.Rows.Count ' ÚÏÏ ÇáÕÝæÝ
ER2 = TS.UsedRange.Rows.Count ' ÚÏÏ ÇáÕÝæÝ
Q2 = TS.Range("P1") ' ÇÓã ÇáÓæÞ
For TR = 2 To ER2
Q1 = TS.Cells(TR, 1) ' ÇÓã ÇáÔÑßÉ
For FR = 2 To ER1
If FS.Cells(FR, 1) = Q1 And FS.Cells(FR, 6) = Q2 Then
TS.Cells(TR, 15) = FS.Cells(FR, 3)
GoTo 9
End If
Next FR
9
Next TR



End Sub

 

[احمدزمان]

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


اخي الفاضل

جرب الكود التالي
Sub SYMBOOL()
Dim FS As Worksheet, TS As Worksheet
Dim FR, TR, ER1, ER2, Q1, Q2
Set FS = Sheets("Symbol") ' ãä æÑÞÉ
Set TS = Sheets(ActiveSheet.Name) ' Çáì æÑÞÉ
ER1 = FS.UsedRange.Rows.Count ' ÚÏÏ ÇáÕÝæÝ
ER2 = TS.UsedRange.Rows.Count ' ÚÏÏ ÇáÕÝæÝ
Q2 = TS.Range("P1") ' ÇÓã ÇáÓæÞ
For TR = 2 To ER2
Q1 = TS.Cells(TR, 1) ' ÇÓã ÇáÔÑßÉ
For FR = 2 To ER1
If FS.Cells(FR, 1) = Q1 And FS.Cells(FR, 6) = Q2 Then
TS.Cells(TR, 15) = FS.Cells(FR, 3)
GoTo 9
End If
Next FR
9
Next TR



End Sub

[nash60]

اخي الكريم احمد :

بداية اود ان اشكرك جزيل الشكر على تكرمك بالرد علي

وبالنسبة للكود وضعته في موديل وعملت استدعاء للموديل في حدث عند ( Private Sub Worksheet_Change ) في ورقة ابوظبي والسعودية وشكل الكود اشتغل وحضر

رموز الشركات بالإنجليزية ولكن استمرت الشاشة بالوميض ثم اصبحت سوداء وعدم استجابة

فان امكن ان تكمل معروفك وتعدل عليه ليعمل بالشكل المطلوب

واكرر شكري لك

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

[nash60]

اخي احمد

مرفق الملف بعد اضافة الكود وبعد تحديث البيانات يعمل الكود دون توقف وتهنز الشاشة حتى اغلاق الملف

من مدير المهام

ارجو ان يتم التعديل ليعمل الكود بطريقة صحيحة

وشكرا

Test02.rar

[احمدزمان]

السلام عليكم

كدة الوضع اختلف

لأن الكود في حدث تغيير الورقة

ولكن  تم عمل الكود على اساس تعمل زر فقط تحديث

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

 

اذا الموضوع محتاج تعديل

[nash60]

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

 

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

للبيانات يتم تحديث رموز الشركات معها مباشرة وانا اسف جدا لاني ما وضحت من البداية وغلبتك معاي

وان شاء الله ربنا يجعله في ميزان حسناتك

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

[احمدزمان]

السلام عليكم

 

يتم التغيير او البحث بمجرد الكتابه في العمود1 الى هوة A

 

ويتم التعامل مع الصف الحالي فقط

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub

 Application.ScreenUpdating = False
 Dim FS As Worksheet, TS As Worksheet
 Dim FR, TR, ER1, ER2, Q1, Q2
 Set FS = Sheets("Symbol") ' ?? ???E
 Set TS = Sheets(ActiveSheet.Name) ' C?? ???E
 ER1 = FS.UsedRange.Rows.Count ' ?II C?????
 Q2 = TS.Range("P1") ' C?? C????
TR = Target.Row
 Q1 = TS.Cells(TR, 1) ' C?? C?O??E
 For FR = 2 To ER1
 If FS.Cells(FR, 1) = Q1 And FS.Cells(FR, 6) = Q2 Then
 TS.Cells(TR, 15) = FS.Cells(FR, 3)
 GoTo 9
 End If
 Next FR
9
Application.ScreenUpdating = True
End Sub

 

[احمدزمان]

Test02.rar

[nash60]

اخي احمد :

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

شكرا لك مرة اخرى ولكن يا ريت لو تجرب تضغط كلك يمين الماوس وتختار تحديث وسيتم تحديث البيانات من خلال النت لكن الرموز لم تظهرفي العمود O 

وانا جربت ولم يعمل الكود ويا ريت تخليه يعمل عند حدوث أي تغيير بالورقة وليس فقط بالعمود A حتى بدون كتابة لاني لن اكتب شئ وسيتم تحديث البيانات من

خلال النت 

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

 مع فائق الاحترام والتقدير.

[احمدزمان]

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

اخي الفاضل في هذه الحالة استخدم الكود القديم مع زر في نفس الورقة

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


اخي الفاضل

جرب الكود التالي
Sub SYMBOOL()
Dim FS As Worksheet, TS As Worksheet
Dim FR, TR, ER1, ER2, Q1, Q2
Set FS = Sheets("Symbol") ' ãä æÑÞÉ
Set TS = Sheets(ActiveSheet.Name) ' Çáì æÑÞÉ
ER1 = FS.UsedRange.Rows.Count ' ÚÏÏ ÇáÕÝæÝ
ER2 = TS.UsedRange.Rows.Count ' ÚÏÏ ÇáÕÝæÝ
Q2 = TS.Range("P1") ' ÇÓã ÇáÓæÞ
For TR = 2 To ER2
Q1 = TS.Cells(TR, 1) ' ÇÓã ÇáÔÑßÉ
For FR = 2 To ER1
If FS.Cells(FR, 1) = Q1 And FS.Cells(FR, 6) = Q2 Then
TS.Cells(TR, 15) = FS.Cells(FR, 3)
GoTo 9
End If
Next FR
9
Next TR



End Sub

[احمدزمان]

وايضا

 

قم باضافة السطر التالي في اول الكويد

    Selection.QueryTable.Refresh BackgroundQuery:=False

حيث سوف يقوم الزر بالتحديث و اضافة اسماء المطلوبة

 

آمل ان يفي هذا بالغرض

 

[حمادة عمر]

السلام عليكم

الاستاذ القدير / احمدزمان

 

بارك الله فيك

كود اكثر من راائع ومتقن

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

[احمدزمان]

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

 

اخواني ابوحنين و حمادة عمر

 

شكرا لكم على كريم مروركما

جزاكم الله كل خير

[nash60]

اخي احمد :

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

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

وجزاك عنا الف خير