سليم الاخرس قام بنشر مايو 8, 2019 مشاركة قام بنشر مايو 8, 2019 السلام عليكم ورحمة الله وبركاته اخواني لدي مرفقين ، الاول ملف جاهز من عمل الاخوة الاكارم بهذا الغروب ، اريد اطبق الملف الاول على ملفي بطريقة المثال الذي طرحته ضمن الملف هل يمكن ان تطبق ام هناك طريقة اخرى ، المهم ان احصل على النتيجة ان امكن بارك الله بجهودكم وجعلها بميزان حسناتكم sa.rar بيانات موظفبن - استدعاء.rar رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر مايو 8, 2019 مشاركة قام بنشر مايو 8, 2019 الملف كبير جداً عشرين الف صنف (كيف لك ان تتذكر ارقامها كلها ) ارى الأفضل ان تقوم بالتصفية على اسم التاجر رابط هذا التعليق شارك More sharing options...
سليم الاخرس قام بنشر مايو 8, 2019 الكاتب مشاركة قام بنشر مايو 8, 2019 53 minutes ago, سليم حاصبيا said: الملف كبير جداً عشرين الف صنف (كيف لك ان تتذكر ارقامها كلها ) ارى الأفضل ان تقوم بالتصفية على اسم التاجر تحياتي استاذي الفاضل لايمكن عمل تصفية على اسم تاجر لان الصنف الواحد يكون لكذا تاجر وكذا سعر ، فأنا لاحظت ان طريقة الاستدعاء اذا دخلت على ملفي ممكن ان تكون مناسبة جدا ارجو التكرم بافادتي ولك خالص التحية رابط هذا التعليق شارك More sharing options...
ابراهيم الحداد قام بنشر مايو 8, 2019 مشاركة قام بنشر مايو 8, 2019 السلام عليكم ورحمة الله جرب هذا الكود ربما يفيدك ضع كود الصنف الذى تبحث عنه فى الخلية "E1" قبل استخدام الكود Sub Call_Data() Dim Arr As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long Dim ws As Worksheet, Kind As Variant Set ws = Sheets("ورقة1") LR = ws.Range("A" & Rows.Count).End(xlUp).Row Kind = ws.Range("E1").Value ws.Range("E3:G" & LR).ClearContents Arr = ws.Range("A5:C" & LR).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) 'On Error Resume Next If Arr(i, 1) = Kind Then p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) Next End If Next If p > 0 Then Range("E3").Resize(p, UBound(Temp, 2)).Value = Temp End Sub 4 رابط هذا التعليق شارك More sharing options...
Ali Mohamed Ali قام بنشر مايو 8, 2019 مشاركة قام بنشر مايو 8, 2019 وعليكم السلام -كود ممتاز استاذ ابراهيم احسنت كل عام وانتم بخير تقبل الله منكم سائر الأعمال 4 رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر مايو 8, 2019 مشاركة قام بنشر مايو 8, 2019 1 ساعه مضت, ابراهيم الحداد said: السلام عليكم ورحمة الله جرب هذا الكود ربما يفيدك ضع كود الصنف الذى تبحث عنه فى الخلية "E1" قبل استخدام الكود Sub Call_Data() Dim Arr As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long Dim ws As Worksheet, Kind As Variant Set ws = Sheets("ورقة1") LR = ws.Range("A" & Rows.Count).End(xlUp).Row Kind = ws.Range("E1").Value ws.Range("E3:G" & LR).ClearContents Arr = ws.Range("A5:C" & LR).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) 'On Error Resume Next If Arr(i, 1) = Kind Then p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) Next End If Next If p > 0 Then Range("E3").Resize(p, UBound(Temp, 2)).Value = Temp End Sub رمضان كريم و صوم مبارك اخي مصطفي شخصياً ارى ان الملف كبير جداً لانشاء حلقات تكرارية (حوالي 20.000 حلقة) لذلك اقترح ادراج كود يعمل على Advanced Filter (اختصاراً للوقت عند تنفيذ الكود) رابط هذا التعليق شارك More sharing options...
عبد القادر محمد مهدى قام بنشر مايو 8, 2019 مشاركة قام بنشر مايو 8, 2019 (معدل) مشاء الله عليك استاذ ابراهيم الحداد .. الله الله.. زادك الله علما وحفطك من كل سوء. تم تعديل مايو 8, 2019 بواسطه عبد القادر محمد مهدى 1 رابط هذا التعليق شارك More sharing options...
وجيه شرف الدين قام بنشر مايو 9, 2019 مشاركة قام بنشر مايو 9, 2019 7 ساعات مضت, سليم حاصبيا said: رمضان كريم و صوم مبارك اخي مصطفي شخصياً ارى ان الملف كبير جداً لانشاء حلقات تكرارية (حوالي 20.000 حلقة) لذلك اقترح ادراج كود يعمل على Advanced Filter (اختصاراً للوقت عند تنفيذ الكود) استاذى الفاضل واخى الحبيب الاستاذ سليم كل عام وحضراتكم بخير بخلول شهر رمضان المبارك اعاده الله عليكم وعلى الامة الاسلامية بالخير واليمن والبركات وبعد اذن الاستاذ ابراهيم الحداد اتفضل الملف لعله يفى بالغرض وادعو الله ان اكون عند حسن ظن استاذى الجليل والحبيب الاستاذ سليم sa.xlsm 1 رابط هذا التعليق شارك More sharing options...
سليم الاخرس قام بنشر مايو 9, 2019 الكاتب مشاركة قام بنشر مايو 9, 2019 10 hours ago, ابراهيم الحداد said: السلام عليكم ورحمة الله جرب هذا الكود ربما يفيدك ضع كود الصنف الذى تبحث عنه فى الخلية "E1" قبل استخدام الكود Sub Call_Data() Dim Arr As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long Dim ws As Worksheet, Kind As Variant Set ws = Sheets("ورقة1") LR = ws.Range("A" & Rows.Count).End(xlUp).Row Kind = ws.Range("E1").Value ws.Range("E3:G" & LR).ClearContents Arr = ws.Range("A5:C" & LR).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) 'On Error Resume Next If Arr(i, 1) = Kind Then p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) Next End If Next If p > 0 Then Range("E3").Resize(p, UBound(Temp, 2)).Value = Temp End Sub استاذي الفاضل .. عذرا منك بعدم خبرتي بالماكرو ، هل بالامكان ارفاق الملف مع زر الماكرو لتنفيذ الامر ؟ واشكركم جميعا على تلبية الطلب رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر مايو 9, 2019 مشاركة قام بنشر مايو 9, 2019 ربما كان هذا الكود اسرع بحوالي 100 مرة باستعمال الدالتين Find & FindNext Sub search_by_salim_Method() Dim My_rg As Range Dim Find_rg As Range Dim find_What$ Dim Ro#, FiXed_Ro# Dim k#: k = 3 With Sheets("ورقة1") Set My_rg = .Range("A4").CurrentRegion.Columns(1) find_What = .Range("E1").Value .Range("E3:G1000").ClearContents End With Set Find_rg = My_rg.Find(find_What, lookat:=1) If Not Find_rg Is Nothing Then Ro = Find_rg.Row FiXed_Ro = Ro Do With Sheets("ورقة1").Range("E" & k).Resize(, 3) .Value = Sheets("ورقة1").Range("A" & Ro).Resize(, 3).Value End With k = k + 1 Set Find_rg = My_rg.FindNext(Find_rg) Ro = Find_rg.Row If Ro = FiXed_Ro Then Exit Do Loop Else MsgBox "This Item Not Exists" End If Set My_rg = Nothing: Set Find_rg = Nothing End Sub الملف مرفق Search_by_find.xlsm 2 رابط هذا التعليق شارك More sharing options...
سليم الاخرس قام بنشر مايو 9, 2019 الكاتب مشاركة قام بنشر مايو 9, 2019 4 ساعات مضت, سليم حاصبيا said: ربما كان هذا الكود اسرع بحوالي 10 مرات باستعمال الدالتين Find & FindNext Sub search_by_salim_Method() Dim My_rg As Range Dim Find_rg As Range Dim find_What$ Dim Ro#, FiXed_Ro# Dim k#: k = 3 With Sheets("ورقة1") Set My_rg = .Range("A4").CurrentRegion.Columns(1) find_What = .Range("E1").Value .Range("E3:G1000").ClearContents End With Set Find_rg = My_rg.Find(find_What, lookat:=1) If Not Find_rg Is Nothing Then Ro = Find_rg.Row FiXed_Ro = Ro Do With Sheets("ورقة1").Range("E" & k).Resize(, 3) .Value = Sheets("ورقة1").Range("A" & Ro).Resize(, 3).Value End With k = k + 1 Set Find_rg = My_rg.FindNext(Find_rg) Ro = Find_rg.Row If Ro = FiXed_Ro Then Exit Do Loop Else MsgBox "This Item Not Exists" End If Set My_rg = Nothing: Set Find_rg = Nothing End Sub الملف مرفق Search_by_find.xlsm 751.45 kB · 0 downloads بارك الله بجهودك وجزاك الله الف خير تم المطلوب 6 ساعات مضت, وجيه شرف الدين said: استاذى الفاضل واخى الحبيب الاستاذ سليم كل عام وحضراتكم بخير بخلول شهر رمضان المبارك اعاده الله عليكم وعلى الامة الاسلامية بالخير واليمن والبركات وبعد اذن الاستاذ ابراهيم الحداد اتفضل الملف لعله يفى بالغرض وادعو الله ان اكون عند حسن ظن استاذى الجليل والحبيب الاستاذ سليم sa.xlsm 700.67 kB · 2 downloads تمام استاذي الفاضل ، بارك الله فيك تم المطلوب واعطت نفس النتيجة مع الاستاذ سليم حاصبيا 16 ساعات مضت, ابراهيم الحداد said: السلام عليكم ورحمة الله جرب هذا الكود ربما يفيدك ضع كود الصنف الذى تبحث عنه فى الخلية "E1" قبل استخدام الكود Sub Call_Data() Dim Arr As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long Dim ws As Worksheet, Kind As Variant Set ws = Sheets("ورقة1") LR = ws.Range("A" & Rows.Count).End(xlUp).Row Kind = ws.Range("E1").Value ws.Range("E3:G" & LR).ClearContents Arr = ws.Range("A5:C" & LR).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) 'On Error Resume Next If Arr(i, 1) = Kind Then p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) Next End If Next If p > 0 Then Range("E3").Resize(p, UBound(Temp, 2)).Value = Temp End Sub سلمت يداك استاذنا الكريم وجزيت الف خير رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر مايو 9, 2019 مشاركة قام بنشر مايو 9, 2019 ربما كان هذا الكود اسرع بحوالي 10 مرات باستعمال الدالتين Find & FindNext Sub search_by_salim_Method() Dim My_rg As Range Dim Find_rg As Range Dim find_What$ Dim Ro#, FiXed_Ro# Dim k#: k = 3 With Sheets("ورقة1") Set My_rg = .Range("A4").CurrentRegion.Columns(1) find_What = .Range("E1").Value .Range("E3:G1000").ClearContents End With Set Find_rg = My_rg.Find(find_What, lookat:=1) If Not Find_rg Is Nothing Then Ro = Find_rg.Row FiXed_Ro = Ro Do With Sheets("ورقة1").Range("E" & k).Resize(, 3) .Value = Sheets("ورقة1").Range("A" & Ro).Resize(, 3).Value End With k = k + 1 Set Find_rg = My_rg.FindNext(Find_rg) Ro = Find_rg.Row If Ro = FiXed_Ro Then Exit Do Loop Else MsgBox "This Item Not Exists" End If Set My_rg = Nothing: Set Find_rg = Nothing End Sub الملف مرفق الرجاء النظر الى هذه الملف لمعرفة ما أعنية من وجهة نظر السرعة Search_by_find_timer .xlsm 2 1 رابط هذا التعليق شارك More sharing options...
وجيه شرف الدين قام بنشر مايو 9, 2019 مشاركة قام بنشر مايو 9, 2019 2 ساعات مضت, سليم حاصبيا said: ربما كان هذا الكود اسرع بحوالي 10 مرات باستعمال الدالتين Find & FindNext Sub search_by_salim_Method() Dim My_rg As Range Dim Find_rg As Range Dim find_What$ Dim Ro#, FiXed_Ro# Dim k#: k = 3 With Sheets("ورقة1") Set My_rg = .Range("A4").CurrentRegion.Columns(1) find_What = .Range("E1").Value .Range("E3:G1000").ClearContents End With Set Find_rg = My_rg.Find(find_What, lookat:=1) If Not Find_rg Is Nothing Then Ro = Find_rg.Row FiXed_Ro = Ro Do With Sheets("ورقة1").Range("E" & k).Resize(, 3) .Value = Sheets("ورقة1").Range("A" & Ro).Resize(, 3).Value End With k = k + 1 Set Find_rg = My_rg.FindNext(Find_rg) Ro = Find_rg.Row If Ro = FiXed_Ro Then Exit Do Loop Else MsgBox "This Item Not Exists" End If Set My_rg = Nothing: Set Find_rg = Nothing End Sub الملف مرفق الرجاء النظر الى هذه الملف لمعرفة ما أعنية من وجهة نظر السرعة Search_by_find_timer .xlsm 752.64 \u0643\u064a\u0644\u0648 \u0628\u0627\u064a\u062a · 1 download فرق السرعة بين الكودين واضح جزاكم الله خير والحمد لله ان تم المطلوب على خير رابط هذا التعليق شارك More sharing options...
عبد القادر محمد مهدى قام بنشر مايو 9, 2019 مشاركة قام بنشر مايو 9, 2019 تسلم اخى سليم بارك الله فيك وزادك علماً وما أجمل المنافسة في العلم بارك الله فيكم جميعا رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان