خطأ فى كود استخراج بيانات

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

الاخوه الكرام

مرفق شيت

به كود يقوم باستخراج

بيانات بناء على3معطيات

والخطأ يحدث

انه دائما يكرر او رقم يتم استخرجه

ارجو المشاهده

استخراج.rar

[saad abed]

اخى ابراهيم ابوليلة

السلام عليكم

هل تريد الارقام  فى العمود Bا لتى تقابل الكلمة فى العمود  c

حتى لو كانت مكرره اكثر من مرة

ام لم تصل الى الفكرة

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

اخى ابراهيم ابوليلة

السلام عليكم

هل تريد الارقام  فى العمود Bا لتى تقابل الكلمة فى العمود  c

حتى لو كانت مكرره اكثر من مرة

ام لم تصل الى الفكرة

اخى سعد

بالظبط كما قولت

كلامك صحيح

فى انتظار التعديل

[حمادة باشا]

الأخ الفاضل/ إبراهيم ابوليله

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

وبعد إستئذان الأستاذ الفاضل/ سعد عابد

تفضل المطلوب بعد تعديل طفيف في نطاق الفلتر

تقبل تحياتي

 

استخراج.rar

[saad abed]

استاذى ابراهيم ابوليلة

استاذى حمادة باشا

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

استاذنكم ان اشارككم الاراء والحلول

Sub gggg()
Sheets("Sheet1").Select
Sheets("Sheet1").Range("f3:h3000").ClearContents
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 3 To Range("c3").End(xlDown).Row
If Sheets("Sheet1").Cells(i, 3) = Cells(2, 6) Then
 Sheets("Sheet1").Cells(i, 6) = Sheets("Sheet1").Cells(i, 2)
End If
If Sheets("Sheet1").Cells(i, 3) = Cells(2, 7) Then
 Sheets("Sheet1").Cells(i, 7) = Sheets("Sheet1").Cells(i, 2)
 End If
 If Sheets("Sheet1").Cells(i, 3) = Cells(2, 8) Then
 Sheets("Sheet1").Cells(i, 8) = Sheets("Sheet1").Cells(i, 2)
 End If
 Range("f3:h300").SpecialCells(xlCellTypeBlanks).Delete

Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

استخراج.rar

تم تعديل مارس 8, 2014 بواسطه سعد عابد

[حمادة عمر]

السلام عليكم

الاخ الحبيب / حمادة باشا

بارك الله فيك

كنت اقوم بتحميل الملف لتنفيذ المطلوب فيه

ولكني شاهدتك قد دخلت للموضوع ... فانتظرت قليلا

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

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

تقبل خالص تحياتي

[حمادة عمر]

السلام عليكم

الاخ الحبيب / سعد عابد

بارك الله فيك

احبك الله الذي احببتنا فيه

كود جميل وطريقه تفكير وتنفيذ اروع

تسير بخطي ثابته نحو التميز والابداع

تقبل خالص تحياتي

[saad abed]

استاذى //حماده عمر

اشكرك كل الشكر على تشجيعك لنا

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

اسال الله ان اكون عند حسن ظن اصدقائى فى المنتدى

[حمادة باشا]

الأستاذ الفاضل/ سعد عابد

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

أنا لم أفعل شيء سوي تعديل رقم واحد - حضرتكم الأستاذ - كود ممتاز وذكي

إستخدمت النسخ بديلا عن الفلتر - وأختصرت الكود إلي الربع تقريبا

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

تم تعديل مارس 8, 2014 بواسطه حمادة باشا

[حمادة باشا]

الأستاذ الفاضل/ حمادة عمر

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

أستفزني الملف لأعرف لماذا يظهر الرقم 7 بشكل دائم مع كون كل شيء يبدو تمام

شاكرا لك كلماتك الطيبة - تقبل تحياتي

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

الأخ الفاضل/ إبراهيم ابوليله

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

وبعد إستئذان الأستاذ الفاضل/ سعد عابد

تفضل المطلوب بعد تعديل طفيف في نطاق الفلتر

تقبل تحياتي

اخى حماده باشا

شرفنى مرورك

واسعدت بمشاركتك

بالفعل تم التعديل

وتم عمل الكود

وواضح طبعا اننى لم اخذ ببالى من بدايه الفلتره

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

 ولكن العيب الاهم فى الكود

وهو انه فى حالة حزف اى من شروط البحث

يتم استخراج بيانات

ارجو التجربه والرد

بارك الله فيك

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

 

استاذى ابراهيم ابوليلة

استاذى حمادة باشا

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

استاذنكم ان اشارككم الاراء والحلول

Sub gggg()
Sheets("Sheet1").Select
Sheets("Sheet1").Range("f3:h3000").ClearContents
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 3 To Range("c3").End(xlDown).Row
If Sheets("Sheet1").Cells(i, 3) = Cells(2, 6) Then
 Sheets("Sheet1").Cells(i, 6) = Sheets("Sheet1").Cells(i, 2)
End If
If Sheets("Sheet1").Cells(i, 3) = Cells(2, 7) Then
 Sheets("Sheet1").Cells(i, 7) = Sheets("Sheet1").Cells(i, 2)
 End If
 If Sheets("Sheet1").Cells(i, 3) = Cells(2, 8) Then
 Sheets("Sheet1").Cells(i, 8) = Sheets("Sheet1").Cells(i, 2)
 End If
 Range("f3:h300").SpecialCells(xlCellTypeBlanks).Delete

Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

اخى سعد

ايه الجمال والحلاوه دى

كود بسيط جدا ومتقن

وياريت لو فيه شرح للكود ان امكن

والاهم ان

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

حاولت افهم من الكود

ولكنى لم اصل الى السطر الذى يقوم بعمل ذلك داخل الكود ارجو التوضيح ان امكن

مشكورا اخى على الاضافه الجميله بارك الله فيك

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

اخى حماده عمر

دائما ما نفتخر بحضور الاساتذه

لمشاركتنا سواء كان ذلك بالرد مع الاجابه

او التشجيع لنا

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

[saad abed]

اخى ابراهيم ابوليلة

ربما لا اجيد الشرح لانى لا زلت تلميذ ولكن طلبك غالى اخى الكريم

سيكون الشرح بعد سرد الكود

Sheets("Sheet1").Select
Sheets("Sheet1").Range("f3:h3000").ClearContents
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

السطر الاول اثرت ان اختار الورقة التى اعمل عليها

السطر الذى يليه الهدف منه وقف اهتزاز الشاشة

السطر االتالى هو وقف الحساب التلقائى فى الاكسيل

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

 

 

 

For i = 3 To Range("c3").End(xlDown).Row
بداية جمل الدوران تبدا من السطر الثالث وتنزل الى اخر سطر فى العمود c

وطبعا تنتهى next

كل هذا لم تبدا فكرة الكود ستبدا بدالة if

If condition  then Statement 1 Statement 2 … .... End if

 

If Sheets("Sheet1").Cells(i, 3) = Cells(2, 6) Then
Sheets("Sheet1").Cells(i, 6) = Sheets("Sheet1").Cells(i, 2)
الشرط هنا ان تتساوى قيم العمود الثالث مع الخلية الموجودة بالصف الثانى والعمود السادس

المطلوب تنفيذه هو نقل القيم التى تتساوى بها فى العمود الثانى الى العمود السادس

ثم وجدت مشكلة وهى القيم تنقل فى نفس الاماكن فوجدت وجود خلايا فارغة فوجدت الحل فى الغاءها

 Range("f3:h300").SpecialCells(xlCellTypeBlanks).Delete
وكررت الموضوع ثلاث مرات

ثم ارجعت الاعدادات الى ما كانت عليه

ارجو ان اكون وفقت

تحياتى

 

 

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

السلام عليكم

الشكر واصل لكل المشاركين ...حفطكم الله

 

الاخ الحبيب / سعد عابد .......هذا هو طريق الخير والبركة في كل شي....ادامكم الله عليه وعلى الخير كله

 

تقبلوا تحياتي وشكري

[saad abed]

استاذى الكبير العلامة // عبدالله باقشير

حفظكم الله   **  رعاكم الله اسال الله ان يبارك فيكم

شرف كبير ان ترد على اى موضوع  لانك استاذى الذى اتتبع ردوده وخطواته

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

تخياتى

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

اخى سعد

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

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