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

كود استدعاء البيانات الى صفحة الضبط بتاريح من وتاريخ حتى

omhamzh

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

 مشاركة
إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

omhamzh

omhamzh

قام بنشر
قام بنشر
السلام عليكم اتمنى مساعدتى بهذه المشاركة
ملف مكون من 3 صفحات منه وله وضبط
الاسماء بمنه هى التى ب له
احتاج موديول اتمكن به من استدعاء البيانات الى صفحة الضبط بتاريح من وتاريخ حتى
هل اجد لديكم حل مع الشكر والعرفان بالجميل
 

منه وله وتقرير بتاريخ من الى.xlsm

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

سليم حاصبيا

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

هذا الكود يقوم بما يلزم

تغيير اسماء الصفحات الى اللغة الأجنبية لحسن نسخ الكود ولصقه 

Option Explicit
Sub Extarct_Data()
      Rem Created By Salim Hasbaya on 29/5/2020
  Dim M As Worksheet, L As Worksheet, R As Worksheet
  Dim Rg_M As Range, Rg_L As Range
  Dim I%, Lr_M%, Lr_L%, RO%
  Dim St_Date As Date, End_Date As Date

  Set M = Sheets("Minho"): Set L = Sheets("Laho")
  Set R = Sheets("Repport")

Lr_M = M.Cells(Rows.Count, 1).End(3).Row
Lr_L = L.Cells(Rows.Count, 1).End(3).Row
R.Range("B2").Resize(25, 2).ClearContents

 If Not IsDate(R.Range("D2")) Or Not IsDate(R.Range("D2")) Then _
  MsgBox "Type Please Correct Dates In The Cells D2 and E2 ": Exit Sub
  St_Date = Application.Min(R.Range("D2:E2"))
  End_Date = Application.Max(R.Range("D2:E2"))
 '++++++++++++++++++++++++++++++++++++++++
 With M
  .Range("A2:AC" & Lr_M).Interior.ColorIndex = xlNone
  RO = 2
  For I = 2 To Lr_M
      If .Cells(I, 1) <= End_Date _
      And .Cells(I, 1) >= St_Date Then
       .Cells(I, 1).Resize(, 29).Interior.ColorIndex = 6
       R.Cells(RO, 2) = Application.Sum(.Cells(I, 4).Resize(, 26))
       RO = RO + 1
      End If
  Next I
 End With
'++++++++++++++++++++++++++++++++
With L
  .Range("A2:AC" & Lr_L).Interior.ColorIndex = xlNone
  RO = 2
  For I = 2 To Lr_L
    If .Cells(I, 1) <= End_Date _
      And .Cells(I, 1) >= St_Date Then
       .Cells(I, 1).Resize(, 29).Interior.ColorIndex = 6
       R.Cells(RO, 3) = Application.Sum(.Cells(I, 4).Resize(, 26))
        RO = RO + 1
    End If
   Next I
 End With
End Sub

الملف مرفق

 

 

 

From_To.xlsm

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

سليم حاصبيا

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

كان من الواجب التوضيح في بادىء الأمر لعدم تضييع الوقت بأمور فائدة منها

الكود الجديد 

Option Explicit
Sub Extarct_Data_By_Columns()
      Rem Created By Salim Hasbaya on 29/5/2020
  Dim M As Worksheet, L As Worksheet, R As Worksheet
  Dim Rg_M As Range, Rg_L As Range
  Dim I%, Lr_M%, Lr_L%, RO%, it
  Dim St_Date As Date, End_Date As Date
  Dim arr, My_sum#
  Set M = Sheets("Minho"): Set L = Sheets("Laho")
  Set R = Sheets("Repport")

Lr_M = M.Cells(Rows.Count, 1).End(3).Row
Lr_L = L.Cells(Rows.Count, 1).End(3).Row
R.Range("B2").Resize(25, 2).ClearContents

 If Not IsDate(R.Range("D2")) Or Not IsDate(R.Range("D2")) Then _
  MsgBox "Type Please Correct Dates In The Cells D2 and E2 ": Exit Sub
  St_Date = Application.Min(R.Range("D2:E2"))
  End_Date = Application.Max(R.Range("D2:E2"))
  
  ReDim arr(1 To 25)
   For I = 1 To 25
   arr(I) = I + 3
   Next
 '++++++++++++++++++++++++++++++++++++++++
 With M
  .Range("A2:AC" & Lr_M).Interior.ColorIndex = xlNone
    For I = 2 To Lr_M
      If .Cells(I, 1) <= End_Date _
        And .Cells(I, 1) >= St_Date Then
       .Cells(I, 1).Resize(, 29).Interior.ColorIndex = 6
     
      End If
  Next I
 End With
''++++++++++++++++++++++++++++++++
With L
  .Range("A2:AC" & Lr_L).Interior.ColorIndex = xlNone

  For I = 2 To Lr_L
    If .Cells(I, 1) <= End_Date _
      And .Cells(I, 1) >= St_Date Then
       .Cells(I, 1).Resize(, 29).Interior.ColorIndex = 6
    End If
   Next I
 End With
 RO = 2
 With M
  For Each it In arr
      For I = 2 To Lr_M
          If .Cells(I, it).Interior.ColorIndex = 6 Then
            My_sum = My_sum + _
            IIf(IsNumeric(.Cells(I, it)), .Cells(I, it), 0)
          End If
      Next I
             R.Cells(RO, 2) = IIf(My_sum > 0, My_sum, vbNullString)
              My_sum = 0: RO = RO + 1
    Next it
 End With
 '++++++++++++++++++++++++++++++++++++
 RO = 2: My_sum = 0
 With L
   For Each it In arr
      For I = 2 To Lr_M
        If .Cells(I, it).Interior.ColorIndex = 6 Then
          My_sum = My_sum + _
          IIf(IsNumeric(.Cells(I, it)), .Cells(I, it), 0)
    
        End If
       Next
        R.Cells(RO, 3) = IIf(My_sum > 0, My_sum, vbNullString)
        My_sum = 0: RO = RO + 1
   Next
 End With
 '++++++++++++++++++++++++++++++++++++
 
End Sub

المرفق من جديد (الماكرو الاول ما زال يعمل اذا لزم الأمر باستعماله)

 

From_To Row_Col.xlsm

  • Like 2
  • Thanks 1
رابط هذا التعليق
شارك
omhamzh

omhamzh

قام بنشر
  • الكاتب
قام بنشر

اتقدم بخالص الشكر الجزيل لحضرتك

فى مشكلة صغيرة التقرير لايستدعى البيانات لاعمدة متفرقة التقرير يعمل إذا كانت البيانات مرصوصة 

احتاج أن يستدعى البيانات إذا كانت البيانات فى اى عمود ليس شرط الترتيب

خالص تحياتي

أى أن البيان فى التقرير يكون فيه كل اسماء الأعمدة وإذا كان بالعمود رقم يستدعى 

مع خالص الشكر

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

سليم حاصبيا

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

تم التعديل

ملاحظة (أرقام الأعمدة يمكن ان لا تتطابق في صفخات  Minho &  Laha )لذلك يجب ادراج عامود اضافي لهذه الأرقام في صفحة  Repport )

لا وقت لدي لعمل ذلك (تركت أرقام الأعمدة للصفخة Minho) 

Option Explicit
Sub Extact_Data_By_Columns()
      Rem Created By Salim Hasbaya on 29/5/2020
      Application.ScreenUpdating = False
  Dim M As Worksheet, L As Worksheet, R As Worksheet
  Dim Rg_M As Range, Rg_L As Range
  Dim I%, Lr_M%, Lr_L%, RO%, it
  Dim St_Date As Date, End_Date As Date
  Dim arr, My_sum#, My_count%
  Set M = Sheets("Minho"): Set L = Sheets("Laho")
  Set R = Sheets("Repport")

Lr_M = M.Cells(Rows.Count, 1).End(3).Row
Lr_L = L.Cells(Rows.Count, 1).End(3).Row
R.Range("A2").Resize(26, 3).ClearContents

 If Not IsDate(R.Range("D2")) Or Not IsDate(R.Range("D2")) Then _
  MsgBox "Type Please Correct Dates In The Cells D2 and E2 ": GoTo Leave_Me_Olone
  St_Date = Application.Min(R.Range("D2:E2"))
  End_Date = Application.Max(R.Range("D2:E2"))
  
  ReDim arr(1 To 26)
   For I = 1 To 26
   arr(I) = I
   Next
 '++++++++++++++++++++++++++++++++++++++++
 With M
  .Range("A2:AC" & Lr_M).Interior.ColorIndex = xlNone
    For I = 2 To Lr_M
      If .Cells(I, 1) <= End_Date _
        And .Cells(I, 1) >= St_Date Then
       .Cells(I, 1).Resize(, 29).Interior.ColorIndex = 6
     
      End If
  Next I
 End With
''++++++++++++++++++++++++++++++++
With L
  .Range("A2:AC" & Lr_L).Interior.ColorIndex = xlNone

  For I = 2 To Lr_L
    If .Cells(I, 1) <= End_Date _
      And .Cells(I, 1) >= St_Date Then
       .Cells(I, 1).Resize(, 29).Interior.ColorIndex = 6
    End If
   Next I
 End With
 RO = 2
 '++++++++++++++++++++++++++++++++++++++++
 With M
 
  For Each it In arr
    My_count = Application.CountA(.Cells(2, it + 3).Resize(Lr_M - 1))
    If My_count = 0 Then GoTo NexT_it
      For I = 2 To Lr_M
           If .Cells(I, it + 3).Interior.ColorIndex = 6 Then
               My_sum = My_sum + _
            IIf(IsNumeric(.Cells(I, it + 3)), .Cells(I, it + 3), 0)
             If .Cells(I, it + 3) <> vbNullString Then
              .Cells(I, it + 3).Interior.ColorIndex = 35
             End If
          End If
      Next I
     R.Cells(RO, 1) = it: R.Cells(RO, 2) = IIf(My_sum <> 0, My_sum, vbNullString)
              My_sum = 0: RO = RO + 1
NexT_it:
    Next it
 End With
 '++++++++++++++++++++++++++++++++++++
 RO = 2: My_sum = 0
 With L
 
  For Each it In arr
    My_count = Application.CountA(.Cells(2, it + 3).Resize(Lr_L - 1))
    If My_count = 0 Then GoTo NexT_itm
      For I = 2 To Lr_L
           If .Cells(I, it + 3).Interior.ColorIndex = 6 Then
               My_sum = My_sum + _
            IIf(IsNumeric(.Cells(I, it + 3)), .Cells(I, it + 3), 0)
             If .Cells(I, it + 3) <> vbNullString Then
              .Cells(I, it + 3).Interior.ColorIndex = 35
             End If
          End If
      Next I
      R.Cells(RO, 3) = IIf(My_sum <> 0, My_sum, vbNullString)
              My_sum = 0: RO = RO + 1
NexT_itm:
    Next it
 End With
 '++++++++++++++++++++++++++++++++++++
Leave_Me_Olone:
  Application.ScreenUpdating = True
End Sub

الملف( للمرة الثّالثة)

 

 

From_To Row_Column_1.xlsm

  • Like 3
رابط هذا التعليق
شارك
omhamzh

omhamzh

قام بنشر
  • الكاتب
قام بنشر

اشكرك جدااااا 

ممكن حضرتك توضح لى ابن اضع اسماء الإعادة فى التقرير اعمل عمود جديد قبل a

شكراااا لسعة صدرك يا استاذ سليم

حياك الله

الكود يعمل 100% فى منه أما له مش عارفة ايه المشكلة

مع خالص تحياتي لك اخي

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

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

سليم حاصبيا

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

ممكن تلافي مشكلة الأعمدة بأدراج الأرقام غلى شكل   X/y   حيث   تدل X  على الصفحة  "Minho"  و  y  تدل على الصفخة "Laho" 

و في حال كان الرقم منفرداً يكون في الصفحة    "Minho" 

تعديل الكود 

Option Explicit
Sub Extact_Data_By_Columns()
      Rem Created By Salim Hasbaya on 29/5/2020
      Application.ScreenUpdating = False
  Dim M As Worksheet, L As Worksheet, R As Worksheet
  Dim Rg_M As Range, Rg_L As Range
  Dim I%, Lr_M%, Lr_L%, RO%, it
  Dim St_Date As Date, End_Date As Date
  Dim arr, My_sum#, My_count%
  Set M = Sheets("Minho"): Set L = Sheets("Laho")
  Set R = Sheets("Repport")

Lr_M = M.Cells(Rows.Count, 1).End(3).Row
Lr_L = L.Cells(Rows.Count, 1).End(3).Row
R.Range("A2").Resize(26, 3).ClearContents

 If Not IsDate(R.Range("D2")) Or Not IsDate(R.Range("D2")) Then _
  MsgBox "Type Please Correct Dates In The Cells D2 and E2 ": GoTo Leave_Me_Olone
  St_Date = Application.Min(R.Range("D2:E2"))
  End_Date = Application.Max(R.Range("D2:E2"))
  
  ReDim arr(1 To 26)
   For I = 1 To 26
   arr(I) = I
   Next
 '++++++++++++++++++++++++++++++++++++++++
 With M
  .Range("A2:AC" & Lr_M).Interior.ColorIndex = xlNone
    For I = 2 To Lr_M
      If .Cells(I, 1) <= End_Date _
        And .Cells(I, 1) >= St_Date Then
       .Cells(I, 1).Resize(, 29).Interior.ColorIndex = 6
     
      End If
  Next I
 End With
''++++++++++++++++++++++++++++++++
With L
  .Range("A2:AC" & Lr_L).Interior.ColorIndex = xlNone

  For I = 2 To Lr_L
    If .Cells(I, 1) <= End_Date _
      And .Cells(I, 1) >= St_Date Then
       .Cells(I, 1).Resize(, 29).Interior.ColorIndex = 6
    End If
   Next I
 End With
 RO = 2
 '++++++++++++++++++++++++++++++++++++++++
 With M
 
  For Each it In arr
    My_count = Application.CountA(.Cells(2, it + 3).Resize(Lr_M - 1))
    If My_count = 0 Then GoTo NexT_it
      For I = 2 To Lr_M
           If .Cells(I, it + 3).Interior.ColorIndex = 6 Then
               My_sum = My_sum + _
            IIf(IsNumeric(.Cells(I, it + 3)), .Cells(I, it + 3), 0)
             If .Cells(I, it + 3) <> vbNullString Then
              .Cells(I, it + 3).Interior.ColorIndex = 35
             End If
          End If
      Next I
              R.Cells(RO, 1) = it: R.Cells(RO, 2) = _
              IIf(My_sum <> 0, My_sum, vbNullString)
              My_sum = 0: RO = RO + 1
NexT_it:
    Next it
 End With
 '++++++++++++++++++++++++++++++++++++
 RO = 2: My_sum = 0
 With L
 
  For Each it In arr
    My_count = Application.CountA(.Cells(2, it + 3).Resize(Lr_L - 1))
    If My_count = 0 Then GoTo NexT_itm
      For I = 2 To Lr_L
           If .Cells(I, it + 3).Interior.ColorIndex = 6 Then
               My_sum = My_sum + _
            IIf(IsNumeric(.Cells(I, it + 3)), .Cells(I, it + 3), 0)
             If .Cells(I, it + 3) <> vbNullString Then
              .Cells(I, it + 3).Interior.ColorIndex = 35
             End If
          End If
      Next I
      R.Cells(RO, 1) = _
           IIf(R.Cells(RO, 1) = vbNullString, it, it & " \  " & R.Cells(RO, 1))
           R.Cells(RO, 3) = _
           IIf(My_sum <> 0, My_sum, vbNullString)
              My_sum = 0: RO = RO + 1
NexT_itm:
    Next it
 End With
 '++++++++++++++++++++++++++++++++++++
Leave_Me_Olone:
  Application.ScreenUpdating = True
End Sub

 

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

omhamzh

قام بنشر
  • الكاتب
قام بنشر

اسفة استاذ سليم

اوضحت لحضرتك بالمرفق 

البيان اسم الاعمدة ثابتة فى منه وله لا تتغير

المطلوب استدعاء المبالغ مجمعة امام كل عمود سواء منه او له الكود

يستدعى البيانات وبيكتب فى خانى البيان 1/2 العمود منه وله

هذه النقطة احتاج تعديلها

تثبيت اسماء الاعمدة وهى من 1 الى 25 فى عمود اسمه البيان فى التقرير وما يستدعى فقط المبالغ من الصفحتين امام اسم العمود 

شكرا جزيل

منه وله وتقرير بتاريخ من الى.xlsm

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

omhamzh

قام بنشر
  • الكاتب
قام بنشر

انا مش عارفة اشكر حضرتك اد ايه لسعة صدرك

تم ارفاق نموذج موضح بالمعادلات لما يقوم به التقرير لكل التواربخ

والمطلوب عمل الاستدعاء بنفس الطريقة لكل تاريخ

سترك الله وحفظك 

انا احتاج هذا التقرير لعمل ضبط يومى لليوم 

شكرا لحضرتك

منه وله وتقرير بتاريخ من الى.xlsm

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

سليم حاصبيا

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

للمرة الالف ( عدم تسمية الأوراق باللغة العربية)

صجيج ان لغتنتا هي لغة القرآن الكريم ولغة الضاد ومن أجمل لغات العالم ونحن نفتخر فيها

لكن للأسف لا تصلخ 100% للمعادلات والأكواد في اكسل (نسبة الخطأ تتعدى ال 90%)

جربي كتابة اسم اي ورقة باللغة العربية وانظري مذا يجري

تم حل الموضوع بالمعادلات (المعادلات محمية / ضد  الكتابة فوقها / لعدم العيث بها عن طريق الخطا زلكنها ليست محمية ضد الحذف)

المعادلة في الخلية C3 مع (Ctl+Shift+Enter) والسحب نزولاُ حتى الخلية C25

و لذلك الأمر بالنسبة للخلية D3 مع تغيير اسم الصفحة داخل المعادلة 

=SUM((Minho!$A$2:$A$1000>=$E$2)*(Minho!$A$2:$A$1000<=$F$2)*(INDIRECT("Minho!"&ADDRESS(2,(MATCH($A3,Minho!$A$1:$AA$1)),1)&":"&ADDRESS(1000,(MATCH($A3,Minho!$A$1:$AA$1)),1))))

 

 

With_formula.xlsm

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

omhamzh

قام بنشر
  • الكاتب
قام بنشر

اشكر حضرتك جدااااااااااااااااااا وتم الموضوع تمام 

هذا هو المطلوب حضرتك عبقرى والله ماشاء الله عليك

شكر ا جزيل الشكر اسال الله العظيم رب العرش العظيم ان يجعله بميزان حسناتك

ممكن استثنى السطر الذى يكتب فيه المجموع فى صفحة minho وlaho من المعادلة الجمع يعنى ما يتجمعش معانا بالمجموع

مع الشكر

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

omhamzh

قام بنشر
  • الكاتب
قام بنشر

صح تمام اشكرك استاذ سليم حضرتك درة المنتدى فعلا خدوم جداااا وشاطر جداا

اشكرك واتمنى تساعدنى فى مشاركتى اسباب توقف الكود عن العمل بعد نقل كل ما بالفورم الى صفحة

مع تحياتى اختك فى الله

omhamzh.xlsm

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

سليم حاصبيا

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

أولاً  لم أر أي اعجاب لأي رد على موضوعاتك فهل النقر بزر الماوس على اعجاب شيء يأخذ وقتاً

ثانيا  أنا لا اتعامل مع اليوزرفورم (خبرتي متواضعة بهذا الشأن)

ثالثاً يرجى ادراج المشاركة الأخيرة في موضوع مستقل لعل احدهم(من له الخبرة الواسعة في اليوزر) يريد ان يشارك في الأجابة

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

سليم حاصبيا

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

ارفعي ملف فيه القليل من البيانات  (و إن كانت عشوائية)   صفين لا تكفي لمعاينة عمل معادلة (10 صفوف اقل شيء)

المعادلات في الملف الذي رفعته لك سابقاً محمية لعدم العيث بها عن طريق الخطأ - لذلك لا تستطعين التعديل عليها

بينما في اي خلية اخرى  يمنكنك عمل اي شيء

تم النعديل على الأسماء   

 المعادلات تعمل بشكل ممتاز في الملف الجدبد المرفق من قبلي (حسب الصورة)

Correction_1.png.44b3abaef076b0658b820df617d6c840.png

مرفق ملف جديد للتوضيح

 

With_formula_New.xlsm

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

omhamzh

قام بنشر
  • الكاتب
قام بنشر

والله العظيم والله العظيم انا مش قصدى اضايق حضرتك

نفس المشكلة بعد مسح البيانات فى الصفحتين 

وعمل تعديل لأول اربع أعمدة بأى اسماء ونفس الاسماء كما هى فى الريبورت

المعادلات أظهرت خطأ وايضا محمية 

ومش عارفة اعمل ايه 

شكرا جزيلا لك اخي الكريم

 

رابط هذا التعليق
شارك
  • أفضل إجابة
سليم حاصبيا

سليم حاصبيا

قام بنشر
  • أفضل إجابة
قام بنشر

تم التعديل على الملف بواسطة معادلة في العامود الأول

بمجرد تغيير اي اسم في الشيت  Minho فقط يتم التغيير في كل النطاقات و تتسري المعادلات الباقية كما تريدين

الصورة المرفقة توضح ذلك

أكرر التغيير في  Minho فقط

my_Pic1.png

الملف مرفق للتجربة

With_formula_New1.xlsm

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

omhamzh

قام بنشر
  • الكاتب
قام بنشر

والله انا هعيط من الاحراج 

انا عملت كل حاجة تمام والمعادلات بتعاندنى

وانا عارفة أن المنتدى هيغضب من طلباتى والاستاذ سليم كمان

بس حطوا نفسكم مكانى وممكن المشاركات دى تفيد أعضاء آخرين والنبى استحملونى

المعادلات فى ريبورت منه بتستدعى مبالغ غلط

والمرافق ياكد كلامى

With_formula_New1.xlsm

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

سليم حاصبيا

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

با أحتي 

قلت لك ضعي القليل من البيانات في الشيتات (التواريخ وتعبئة قليل من الصفوف )لمعرفة اين الخطأ و وضع اليد على الجرح

انا عندي الملف يعمل بشكل جيد جداً

 وقد رفعته لك عدة مرات وفي كل مرة يتم التعديل عليه

بدون ملف لا يحتوي على بيانات (10 صفوف على الأقل مع تواريح مختلفة) أعتذر عن المساعدة

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

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