اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

تعديل على استدعاء بيانات

سليم الاخرس

بواسطه سليم الاخرس
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

سليم الاخرس

سليم الاخرس

قام بنشر
قام بنشر

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

اخواني لدي مرفقين ، الاول ملف جاهز من عمل الاخوة الاكارم بهذا الغروب ، اريد اطبق الملف الاول على ملفي بطريقة المثال الذي طرحته ضمن الملف

هل يمكن ان تطبق ام هناك طريقة اخرى ، المهم ان احصل على النتيجة  ان امكن 

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

sa.rar بيانات موظفبن - استدعاء.rar

رابط هذا التعليق
شارك
سليم الاخرس

سليم الاخرس

قام بنشر
  • الكاتب
قام بنشر
53 minutes 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

 

  • Like 4
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر
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 (اختصاراً للوقت عند  تنفيذ الكود)

 

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

وجيه شرف الدين

قام بنشر
قام بنشر
7 ساعات مضت, سليم حاصبيا said:

رمضان كريم و صوم مبارك

اخي مصطفي 

شخصياً ارى ان الملف كبير جداً لانشاء حلقات تكرارية (حوالي 20.000 حلقة)

لذلك اقترح ادراج كود يعمل على Advanced Filter (اختصاراً للوقت عند  تنفيذ الكود)

 

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

sa.xlsm

  • Like 1
رابط هذا التعليق
شارك
سليم الاخرس

سليم الاخرس

قام بنشر
  • الكاتب
قام بنشر
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

 

استاذي الفاضل .. عذرا منك بعدم خبرتي بالماكرو ، هل بالامكان ارفاق الملف مع زر الماكرو لتنفيذ الامر ؟ واشكركم جميعا على تلبية الطلب  

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

ربما كان هذا الكود اسرع بحوالي 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

  • Like 2
رابط هذا التعليق
شارك
سليم الاخرس

سليم الاخرس

قام بنشر
  • الكاتب
قام بنشر
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

 

سلمت يداك استاذنا الكريم وجزيت الف خير 

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

ربما كان هذا الكود اسرع بحوالي 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

  • Like 2
  • Thanks 1
رابط هذا التعليق
شارك
وجيه شرف الدين

وجيه شرف الدين

قام بنشر
قام بنشر
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

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

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept