أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
هانى على ali mohamed ali-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة منع ادخال البيانات بعدة شروط اكسيل اسئله واجابات


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





مطلوب كود استخراج بيانات بالمصفوفات

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


موضوع مغلق

الصفحة 1 من 2 < 1 2 > الأخيرة »


16-08-2022 05:36 مساء
EM_ACC
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-08-2017
رقم العضوية : 84
المشاركات : 232
الجنس : ذكر
تاريخ الميلاد : 24-9-1981
الدعوات : 1
يتابعهم : 4
يتابعونه : 3
قوة السمعة : 338
 offline 

السلام عليكم ورحمه الله وبركاته
الاخوه الافاضل
لدى شيت اقوم بادخال بيانت به
وشيت اخر اقوم باستخراج الاجمالى به
اريد كود يكون سريع فى استخراج البيانات
لاننى جربت الحلقات التكراريه
ونجحت فى عمليه الاستخراج
لكن مع كثره البيانات تكن عمليه الاستخراج بطيئه
تقبلوا تحياتى
 
 
  استخراج-23.xlsm   تحميل xlsm مرات التحميل :(8)
الحجم :(10.736) KB



أفضل إجابة مقدمة من ابراهيم الحداد وهي:
السلام عليكم ورحمة الله
اعتقد ان الكود يكون افضل هكذا
Sub CollData()
Dim ws As Worksheet, Sh As Worksheet
Dim LR  As Long, i As Long, j As Long, p As Long
Dim Arr As Variant, Tmp As Variant
Dim WF As WorksheetFunction, x As Long
Dim Tim1, Tim2

   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
    Application.EnableEvents = False
      Application.Calculation = xlCalculationManual


Set ws = Sheets("الادخال")
Set Sh = Sheets("استخراج بيانات")
Set WF = WorksheetFunction
LR = ws.Range("a" & ws.Rows.Count).End(3).Row
Tim1 = Sh.Range("A1"): Tim2 = Sh.Range("B1")
Start = Timer
Arr = ws.Range("A4:p" & LR).Value
ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 1))
For i = 1 To UBound(Arr, 1)
x = WF.CountIf(ws.Range("p4:p" & i + 3), Arr(i, 16))
If Arr(i, 1) >= Tim1 And Arr(i, 1) <= Tim2 And x = 1 Then
p = p + 1
For j = 1 To 11
Tmp(p, j) = Arr(i, Choose(j, 16, 2, 3, 4, 5, 6, 8, 9, 11, 12, 12))
y = WF.SumIf(ws.Range("k4:k" & LR), Tmp(p, 9), ws.Range("o4:o" & LR))
Tmp(p, 11) = y
Next
End If
Next

If p > 0 Then Sh.Range("a4").Resize(p, UBound(Tmp, 2)).Value = Tmp

MsgBox Round(Timer - Start, 2) & " Seconds"
     Application.ScreenUpdating = True
     Application.DisplayAlerts = True
      Application.EnableEvents = True
       Application.Calculation = xlCalculationAutomatic

End Sub
عرض الإجابة



توقيع :EM_ACC
إبراهيم أبوليله

16-08-2022 09:24 مساء
مشاهدة مشاركة منفردة [1]
ابراهيم الحداد
خبير
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 236
الجنس : ذكر
الدعوات : 4
يتابعهم : 0
يتابعونه : 33
قوة السمعة : 2329
عدد الإجابات: 30
 offline 
look/images/icons/i1.gif مطلوب كود استخراج بيانات بالمصفوفات
السلام عليكم ورحمة الله
استخدم هذا الكود ربما هذا ما تقصده
Sub CollData()
Dim ws As Worksheet, Sh As Worksheet
Dim LR  As Long, i As Long, j As Long, p As Long
Dim Arr As Variant, Tmp As Variant
Dim WF As WorksheetFunction, x As Integer
Set ws = Sheets("الادخال")
Set Sh = Sheets("الاجمالى")
Set WF = WorksheetFunction
LR = ws.Range("B" & Rows.Count).End(3).Row
Arr = ws.Range("A5:E" & LR).Value
ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 1))
For i = 1 To UBound(Arr, 1)
x = WF.CountIf(ws.Range("B5:B" & i + 4), Arr(i, 2))
If x = 1 Then
p = p + 1
For j = 1 To 5
y = y + Tmp(p, 5)
Tmp(p, j) = Arr(i, j)
y = WF.SumIf(ws.Range("B5:B" & LR), Tmp(p, 2), ws.Range("E5:E" & LR))
Tmp(p, 5) = y
Next
End If
Next
If p > 0 Then Sh.Range("A5").Resize(p, UBound(Tmp, 2)).Value = Tmp
End Sub

17-08-2022 07:11 مساء
مشاهدة مشاركة منفردة [2]
EM_ACC
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-08-2017
رقم العضوية : 84
المشاركات : 232
الجنس : ذكر
تاريخ الميلاد : 24-9-1981
الدعوات : 1
يتابعهم : 4
يتابعونه : 3
قوة السمعة : 338
 offline 
look/images/icons/i1.gif مطلوب كود استخراج بيانات بالمصفوفات
السلام عليكم
اخى واستاذى الفاضل
ابراهيم الحداد
مشكورا بارك الله فيك
بالفعل الكود ياتى بالنتيجه الصحيحه
ولكن به مشكله
عند الوصول بالبيانات الى السطر 5300
يحدث خطأ
تقبل تحياتى
 
 
  استخراج-23.xlsm   تحميل xlsm مرات التحميل :(10)
الحجم :(255.365) KB

توقيع :EM_ACC
إبراهيم أبوليله

18-08-2022 09:05 صباحا
مشاهدة مشاركة منفردة [3]
osama barawy
عضو
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 30-10-2017
رقم العضوية : 1307
المشاركات : 23
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 27-5-1970
يتابعهم : 0
يتابعونه : 1
قوة السمعة : 320
عدد الإجابات: 11
 offline 
look/images/icons/i1.gif مطلوب كود استخراج بيانات بالمصفوفات
السلام عليكم
ممكن تجرب استعمال pivot table وضع classic layout
 
 
 
  استخراج-23 Pivot Table.xlsm   تحميل xlsm مرات التحميل :(2)
الحجم :(411.957) KB



تم تحرير المشاركة بواسطة :osama barawy
بتاريخ:18-08-2022 09:05 صباحا


18-08-2022 11:24 صباحا
مشاهدة مشاركة منفردة [4]
EM_ACC
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-08-2017
رقم العضوية : 84
المشاركات : 232
الجنس : ذكر
تاريخ الميلاد : 24-9-1981
الدعوات : 1
يتابعهم : 4
يتابعونه : 3
قوة السمعة : 338
 offline 
look/images/icons/i1.gif مطلوب كود استخراج بيانات بالمصفوفات
الاستاذ الفاضل
اسامه
مشكورا بارك الله فيك
طبعا افكار جميله وحلول رائعه
ان شاء الله
احاول اتعلم البيفوت تيبل ده

فى انتظار مشاركات اخرى من الاخوه الاعضاء

تقبل تحياتى
 
توقيع :EM_ACC
إبراهيم أبوليله

18-08-2022 01:09 مساء
مشاهدة مشاركة منفردة [5]
ابراهيم الحداد
خبير
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 236
الجنس : ذكر
الدعوات : 4
يتابعهم : 0
يتابعونه : 33
قوة السمعة : 2329
عدد الإجابات: 30
 offline 
look/images/icons/i1.gif مطلوب كود استخراج بيانات بالمصفوفات
السلام عليكم ورحمة الله
اعتقد ان الكود يكون افضل هكذا
Sub CollData()
Dim ws As Worksheet, Sh As Worksheet
Dim LR  As Long, i As Long, j As Long, p As Long
Dim Arr As Variant, Tmp As Variant
Dim WF As WorksheetFunction, x As Long
Dim Tim1, Tim2

   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
    Application.EnableEvents = False
      Application.Calculation = xlCalculationManual


Set ws = Sheets("الادخال")
Set Sh = Sheets("استخراج بيانات")
Set WF = WorksheetFunction
LR = ws.Range("a" & ws.Rows.Count).End(3).Row
Tim1 = Sh.Range("A1"): Tim2 = Sh.Range("B1")
Start = Timer
Arr = ws.Range("A4:p" & LR).Value
ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 1))
For i = 1 To UBound(Arr, 1)
x = WF.CountIf(ws.Range("p4:p" & i + 3), Arr(i, 16))
If Arr(i, 1) >= Tim1 And Arr(i, 1) <= Tim2 And x = 1 Then
p = p + 1
For j = 1 To 11
Tmp(p, j) = Arr(i, Choose(j, 16, 2, 3, 4, 5, 6, 8, 9, 11, 12, 12))
y = WF.SumIf(ws.Range("k4:k" & LR), Tmp(p, 9), ws.Range("o4:o" & LR))
Tmp(p, 11) = y
Next
End If
Next

If p > 0 Then Sh.Range("a4").Resize(p, UBound(Tmp, 2)).Value = Tmp

MsgBox Round(Timer - Start, 2) & " Seconds"
     Application.ScreenUpdating = True
     Application.DisplayAlerts = True
      Application.EnableEvents = True
       Application.Calculation = xlCalculationAutomatic

End Sub

18-08-2022 07:34 مساء
مشاهدة مشاركة منفردة [6]
osama barawy
عضو
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 30-10-2017
رقم العضوية : 1307
المشاركات : 23
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 27-5-1970
يتابعهم : 0
يتابعونه : 1
قوة السمعة : 320
عدد الإجابات: 11
 offline 
look/images/icons/i1.gif مطلوب كود استخراج بيانات بالمصفوفات
السلام عليكم

مرفق كود اظنه قد يكون سريعا .  كما بالملف التالي 
ملحوظه:
قمت بتغيير اماكن الاعمده لتيسير عمل الفلتر المتقدم 
واضافة مجموعه خلايا لخصائص الفلترة ويقوم الكود بملئها تلقائيا
اسماء اوراق العمل مكتوبه باللغه الانجليزيه  "الادخال" = "Data"  و "استخراج بيانات" ="Report"

Dim LastRow As Long
Dim LastDataRow As Long
 Application.ScreenUpdating = False
Sheets("Data").Select
'Clear Target Area
    LastRow = Sheets("Data").Cells(Rows.Count, "x").End(xlUp).Row
    If LastRow > 2 Then Range("X2:AI" & LastRow).Clear
       
    LastRow = Sheets("Report").Cells(Rows.Count, "a").End(xlUp).Row
    If LastRow > 2 Then Sheets("Report").Range("A2:M" & LastRow).Clear
 
' Activate Filter Criteria1
    Range("V2").Value = Range("B2").Value2
    Range("U2").Value = Range("B2").Value2
    Range("V3").Formula2R1C1 = "=" & Chr(34) & "<=" & Sheets("Report").Range("D1").Value2 & Chr(34)
    Range("U3").Formula2R1C1 = "=" & Chr(34) & ">=" & Sheets("Report").Range("B1").Value2 & Chr(34)
' Performing advance Filter
    LastDataRow = Sheets("Data").Cells(Rows.Count, "a").End(xlUp).Row
    Range("A2:L" & LastDataRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
        ("U2:V3"), CopyToRange:=Range("x2"), Unique:=True
 
   LastRow = Sheets("Data").Cells(Rows.Count, "x").End(xlUp).Row
   Range("X2:AI" & LastRow).Copy
   Sheets("Report").Select
   Range("A2").Select
   ActiveSheet.Paste
    
    
    Sheets("Data").Range("X2:AI" & LastRow).Clear
    
   LastRow = Sheets("Report").Cells(Rows.Count, "a").End(xlUp).Row
     Sheets("Data").Select
     Range("P2").Copy
    

    Sheets("Report").Select
    Range("m2").Select
    ActiveSheet.Paste
    Sheets("Report").Range("m3:m" & LastRow).Formula = "=SUMIF(data!A$3:A$" & LastDataRow & ",A3,Data!P$3:P$" & LastDataRow & ")"
 
  Application.ScreenUpdating = True

لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  استخراج-ob.xlsm   تحميل xlsm مرات التحميل :(0)
الحجم :(262.509) KB



الصفحة 1 من 2 < 1 2 > الأخيرة »


الكلمات الدلالية
مطلوب ، استخراج ، بيانات ، بالمصفوفات ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 04:35 مساء