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

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
ashraf_hertlion hassona229-- لا تميز خلال هذه الفترة YasserKhalil مطلوب تعديل الكود للطباعة اكسيل اسئله واجابات


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





استدعاء بيانات من sheets متعددة باستخدام تاريخ

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


موضوع مغلق

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


07-07-2020 08:21 مساء
yara ahmed
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 07-07-2020
رقم العضوية : 19921
المشاركات : 24
الجنس : أنثى
يتابعهم : 1
يتابعونه : 1
قوة السمعة : 64
 offline 

السلام عليكم


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

وهو


المطلوب استدعاء البيانات من Sheets الملونة بالاخضر اى كان عددها

هنا بالتاريخ from to


وهذا Sheet DataReport هو النتيجة المتوقع الحصول عليها عند تنفيذ الماكرو

thank you so much


 
 
  استدعاء GreenSheets.xlsm   تحميل xlsm مرات التحميل :(4)
الحجم :(29.176) KB


07-07-2020 10:08 مساء
مشاهدة مشاركة منفردة [1]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif استدعاء بيانات من sheets متعددة باستخدام تاريخ
وعليكم السلام
أهلاً بكي أختي الكريمة في المنتدى 
جربي الكود التالي عله يفي بالغرض إن شاء الله
Sub Test()
    Dim a, ws As Worksheet, sh As Worksheet, b As Boolean, r As Long, n As Long, j As Long, m As Long
    Application.ScreenUpdating = False
        Set sh = ThisWorkbook.Worksheets("DataReport")
        sh.Range("A2:J" & Rows.Count).Clear
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name <> sh.Name And ws.Tab.Color = 5287936 Then
                ReDim a(1 To 10000, 1 To 9)
                b = False: n = 0
                With ws
                    For r = 6 To ws.Cells(Rows.Count, 1).End(xlUp).Row
                        If ws.Cells(r, 1).Value2 >= sh.Range("L2").Value2 And ws.Cells(r, 1).Value2 <= sh.Range("K2").Value2 Then
                            b = True
                            n = n + 1
                            For j = LBound(a, 2) To UBound(a, 2)
                                a(n, j) = ws.Cells(r, j + 1).Value
                            Next j
                        End If
                    Next r
                    If b Then
                        m = sh.Cells(Rows.Count, 2).End(xlUp).Row + 1
                        sh.Cells(m, 1).Value = ws.Name
                        sh.Cells(m, 2).Resize(n, UBound(a, 2)).Value = a
                    End If
                End With
            End If
        Next ws
    Application.ScreenUpdating = True
End Sub

07-07-2020 11:52 مساء
مشاهدة مشاركة منفردة [2]
yara ahmed
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 07-07-2020
رقم العضوية : 19921
المشاركات : 24
الجنس : أنثى
يتابعهم : 1
يتابعونه : 1
قوة السمعة : 64
 offline 
look/images/icons/i1.gif استدعاء بيانات من sheets متعددة باستخدام تاريخ
كود ممتاز بل عبقرى من البروفيسور العبقرى ياسر بك خليل الكود يعمل بكفائة لانه تنفيذ  اسم كبير بالعالم العربى فى مجال vba
هدية مقبولة بروفيسور
زادك الله علما
ممكن اضافة بسيطة وضع سطربن سطر يجمع ما فوقه وتحته سطر به رأس الاعمدة   بين كلsheet name عند الاستدعاء مثل السطرين الاصفر بالصورة للطباعة
واذا استعصى الامر ممكن وضع سطرين فارغين وانا اضع بهما الاجمالى ومعادلة sum واجمع ما فوقه يدويا
والاخر اضع به رؤس الاعمدة التى باول سطر
واين يمكن تغير حجم الخط فى الكود بروفيسور
مشكور سيدى
زادك الله من فضله ورزقك دعاء الصالحين
 
 
  8.jpg   تحميل jpg 8.jpg مرات التحميل :(2)
الحجم :(226.131) KB
 


08-07-2020 01:34 صباحا
مشاهدة مشاركة منفردة [3]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif استدعاء بيانات من sheets متعددة باستخدام تاريخ
بارك الله فيكي .. يؤسفني أن أعتذر لعدم القدرة على المشاركة لبعض الوقت ،ـ وسأترك ما تبقى للأخوة الأعضاء للمساهمة ، وحاولي دراسة الكود وتتبع الكود سطر بسطر لأن الهدف من المنتدى تعليمي وليس خدمي.

08-07-2020 09:13 صباحا
مشاهدة مشاركة منفردة [4]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif استدعاء بيانات من sheets متعددة باستخدام تاريخ
جرب هذا الكود

Option Explicit
Sub Salim_Code()

 Dim a()
 Dim Sh As Worksheet, D As Worksheet
 Dim r%, n%, j%, m%, k%, x%, t%
 Dim Rg As Range
 Dim dat1 As Date, dat2 As Date
 Dim Itm
    Application.ScreenUpdating = False
k = 1
 Set D = ThisWorkbook.Worksheets("DataReport")
 D.Range("A2:k" & Rows.Count).Clear
      If Not IsDate(D.Range("M2")) Or _
          Not IsDate(D.Range("M2")) Then
           MsgBox "Wrong dates in cells M1 Or N2"
          GoTo Leave_me_Olone
      End If
 dat1 = Application.Min(D.Range("M2:N2"))
 dat2 = Application.Max(D.Range("M2:N2"))

  For Each Sh In ThisWorkbook.Worksheets
   If Sh.Name <> D.Name And Sh.Tab.Color = 5287936 Then
    ReDim Preserve a(1 To k): a(k) = Sh.Name: k = k + 1
 End If
 Next
  m = 2: k = 2
 For Each Itm In a
  Set Sh = Sheets(Itm)
   x = Sh.Cells(Rows.Count, 1).End(3).Row
    For t = 6 To x
      If Sh.Cells(t, 1) >= dat1 And Sh.Cells(t, 1) <= dat2 Then
        If Rg Is Nothing Then
         Set Rg = Sh.Cells(t, 1).Resize(, 10)
        Else
         Set Rg = Union(Rg, Sh.Cells(t, 1).Resize(, 10))
        End If
      End If
   
    Next t
   If Not Rg Is Nothing Then
       D.Cells(m, 1) = Rg.Parent.Name
       Rg.Copy D.Cells(m, 2)
      m = D.Cells(Rows.Count, 2).End(3).Row + 3
      D.Cells(m - 2, 1) = "Totat"
      D.Cells(m - 2, 4).Resize(, 8).Formula = _
      "=SUM(D" & k & ":D" & m - 3 & ")"
      D.Cells(m - 1, 3).Resize(, 10).Value = _
      D.Cells(1, "C").Resize(, 10).Value
      D.Cells(m - 2, 1).Resize(, 11).Interior.ColorIndex = 35
      D.Cells(m - 1, 1).Resize(, 11).Interior.ColorIndex = 40
      k = m
   End If
   Set Rg = Nothing
 Next Itm
 Set Rg = D.Range("a2").CurrentRegion
  If Rg.Rows.Count > 1 Then
   Set Rg = Rg.Offset(1).Resize(Rg.Rows.Count - 1)
    With Rg
     .Borders.LineStyle = 1
     .InsertIndent 1
     .Font.Bold = True
     .Font.Size = 14
     .Value = .Value
    End With
  End If
Leave_me_Olone:
  Set Sh = Nothing: Set D = Nothing
  Set Rg = Nothing: Erase a
  
  Application.ScreenUpdating = True

End Sub

الملف مرفق

 
 
 
  yara_salim.xlsm   تحميل xlsm مرات التحميل :(11)
الحجم :(51.326) KB


08-07-2020 05:10 مساء
مشاهدة مشاركة منفردة [5]
yara ahmed
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 07-07-2020
رقم العضوية : 19921
المشاركات : 24
الجنس : أنثى
يتابعهم : 1
يتابعونه : 1
قوة السمعة : 64
 offline 
look/images/icons/i1.gif استدعاء بيانات من sheets متعددة باستخدام تاريخ
شئ لا يصدق
فعلا حضرتك ممتاز ايضا حضرتك بروفيسور رائع وكان لدى مشكلة كبيرة بهذا التقرير تسلم مشكور
اشكرك كلك زوق 
زادك الله علما
بارك الله فيك اخى

08-07-2020 06:02 مساء
مشاهدة مشاركة منفردة [6]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif استدعاء بيانات من sheets متعددة باستخدام تاريخ
جزاك الله خيراً أخي الحبيب سليم والحمد لله الذي بنعمته تتم الصالحات.


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


الكلمات الدلالية
باستخدام ، تاريخ ، متعددة ، sheets ، بيانات ، استدعاء ،


 










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

الساعة الآن 08:14 مساء