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

سليم الاخرس · مايو 8, 2019

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

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

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

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

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

**سليم حاصبيا** · مايو 8, 2019

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

عشرين الف صنف (كيف لك ان تتذكر ارقامها كلها )

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

سليم الاخرس · مايو 8, 2019

53 minutes ago, سليم حاصبيا said:

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

عشرين الف صنف (كيف لك ان تتذكر ارقامها كلها )

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

تحياتي استاذي الفاضل

لايمكن عمل تصفية على اسم تاجر لان الصنف الواحد يكون لكذا تاجر وكذا سعر ، فأنا لاحظت ان طريقة الاستدعاء اذا دخلت على ملفي ممكن ان تكون مناسبة جدا

ارجو التكرم بافادتي ولك خالص التحية

**ابراهيم الحداد** · مايو 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

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

عبد القادر محمد مهدى · مايو 8, 2019

مشاء الله عليك استاذ ابراهيم الحداد .. الله الله.. زادك الله علما وحفطك من كل سوء.

تم تعديل مايو 8, 2019 بواسطه عبد القادر محمد مهدى

**وجيه شرف الدين** · مايو 9, 2019

7 ساعات مضت, سليم حاصبيا said:

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

اخي مصطفي

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

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

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

sa.xlsm

سليم الاخرس · مايو 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

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

**سليم حاصبيا** · مايو 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

سليم الاخرس · مايو 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

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

**سليم حاصبيا** · مايو 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

**وجيه شرف الدين** · مايو 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

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

عبد القادر محمد مهدى · مايو 9, 2019

تسلم اخى سليم بارك الله فيك وزادك علماً

وما أجمل المنافسة في العلم

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

تسجيل الدخول

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

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

سليم الاخرس

سليم حاصبيا

سليم الاخرس

ابراهيم الحداد

Ali Mohamed Ali

سليم حاصبيا

عبد القادر محمد مهدى

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

سليم الاخرس

سليم حاصبيا

سليم الاخرس

سليم حاصبيا

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

عبد القادر محمد مهدى

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information