طلب كود بحث وترحيل وعرض بيانات وفق شرط محدد

[م.هاشم]

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

في البداية أود أن أشكر جميع القائمين والمشاركين في هذا المنتدى الرائع والذي تعلمت من خلالة الكثير

فجزاكم الله خير الجزاء

وأطلب عمل كود بحسب التفصيل الوارد في الصورة المرفقة والملف المرفق

ولكم جزيل الشكر وعظيم الإمتنان

Form_V3.xlsm

[سليم حاصبيا]

يجب ابقاء الصف رقم 2 فارغاً (لقصل البيانات المتغيرة عن الثابتة)
تم اخفاءه والبيانات  تبدأ من الصف رقم 3

الماكرو

Option Explicit

Sub From_dash_to_data()
Dim Dash As Worksheet, Dt As Worksheet
Dim Cret As Range, x%, y%

Set Dash = Sheets("Dashboard"): Set Dt = Sheets("DATA")
If Not IsNumeric(Dash.Range("C1")) Then
Exit Sub
End If
y = Int(Abs(Dash.Range("C1")))
Dash.Range("C1") = y
Dash.Range("A3").CurrentRegion.ClearContents
Set Cret = Dash.Range("A1")
Dt.Range("A1").CurrentRegion.AutoFilter 1, Cret
Dt.Range("A1").CurrentRegion.SpecialCells(12).Copy

Dash.Range("A3").PasteSpecial (12)
Dash.Range("A3").CurrentRegion.Sort Dash.Range("E3"), 2, Header:=1
x = Dash.Range("A3").CurrentRegion.CurrentRegion.Rows.Count
Dash.Range("A4").Offset(y) _
.Resize(x - y - 1).EntireRow.Delete

Dash.Range("A3").Offset(y + 1, 2) = _
  Evaluate("=SUM(C4:C" & y + 3 & ")")
 Application.CutCopyMode = False
 If Dt.AutoFilterMode Then Dt.Range("a1").AutoFilter
 Dash.Activate
 Dash.Range("A3").Select
End Sub

File Included

Hashem.xlsm

[م.هاشم]

أقف عاجزا ً عن الشكر استاذي الفاضل الاستاذ سليم حاصبيا  

على هذا الكود الرائع والعمل المتميز

والذي سوف أحتاج بعض الوقت لأفهم طريقة عمله

حيث أن لي محاولات وإن كانت بسيطة في كتابة الاكواد إلا أنها لا ترقى لمستوى هذا الكود المتميز

وإذا سمحت لي أود أن أطلب تعديل بسيط وهو وعرض النتائج من التاريخ الأقدم في أعلى الجدول والتاريخ الأحدث في أسفل الجدول

كما أود الإستفسار عن إمكانية عدم إضهار رسالة خطئ في حال كتابة رقم في الخلية

C1

مثال لو وضعت رقم 50 فإنه يضهر رسالة خطئ لعدم وجود بيانات بهذا العدد والمطلوب إن أمكن عرض جميع البيانات الموجودة وإن قلت عن الرقم المحدد دون إظهار رسالة خطئ إن أمكن ذلك

وأجدد الشكر والتقدير

ولكم خالص الدعاء بالخير والتوفيق

[سليم حاصبيا]

لعكس الترتيب استبدل قي هذا السطر من الكود الرقم 2 بالرقم 1

Dash.Range("A3").CurrentRegion.Sort Dash.Range("E3"), 2, Header:=1

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

Option Explicit

Sub From_dash_to_data()
Dim Dash As Worksheet, Dt As Worksheet
Dim Cret As Range, x%, y%, Ro_D
Application.ScreenUpdating = False
Set Dash = Sheets("Dashboard"): Set Dt = Sheets("DATA")
Dash.Range("A3").CurrentRegion.Clear

Ro_D = Dt.Range("A3").CurrentRegion.CurrentRegion.Rows.Count
If Dash.Range("C1") = "" Then
    MsgBox "Pleae Type A number In The cell C1" & Chr(10) & _
        "Last Than " & Ro_D - 2
    GoTo Bay_Bay
End If

If Not IsNumeric(Dash.Range("C1")) Then
       MsgBox "Tex Not Allowed in The cell C1" & Chr(10) & _
      "Pleae Type A number"
   GoTo Bay_Bay
End If
y = Int(Abs(Dash.Range("C1")))
Dash.Range("C1") = y
Set Cret = Dash.Range("A1")
Dt.Range("A1").CurrentRegion.AutoFilter 1, Cret
Dt.Range("A1").CurrentRegion.SpecialCells(12).Copy

Dash.Range("A3").PasteSpecial (12)
Dash.Range("A3").CurrentRegion.Sort Dash.Range("E3"), 2, Header:=1
x = Dash.Range("A3").CurrentRegion.CurrentRegion.Rows.Count
If x - y < 2 Then
 With Dash.Range("A4").Offset(x - 1, 2)
  .Value = Evaluate("=SUM(C4:C" & x + 2 & ")")
  .Interior.ColorIndex = 3
  .Font.ColorIndex = 2
 End With

 Else
  Dash.Range("A4").Offset(y) _
 .Resize(x - y - 1).EntireRow.Delete
  With Dash.Range("A3").Offset(y + 1, 2)
  .Value = Evaluate("=SUM(C4:C" & y + 3 & ")")
  .Interior.ColorIndex = 3
  .Font.ColorIndex = 2
  End With
End If

 Application.CutCopyMode = False
 If Dt.AutoFilterMode Then Dt.Range("A1").AutoFilter
 Dash.Activate
 With Dash.Range("A3").CurrentRegion
  .Borders.LineStyle = 1
  .InsertIndent 1
  .Font.Bold = True
  .Font.Size = 14
  .Rows(1).Interior.ColorIndex = 35
  .Rows(1).HorizontalAlignment = 3
 End With
 Dash.Range("A3").Select
 
Bay_Bay:
 Application.ScreenUpdating = True
End Sub

 

الملف من جديد

 

Hashem_Super.xlsm

[م.هاشم]

استاذي الفاضل الاستاذ سليم حاصبيا

أسئل الله العظيم في هذا الصباح أن يسعدك وييسر أمورك ويرزقك من حيث تحتسب ومن حيث لا تحتتسب

فهذا الكود والتعديل الجميل اللذي تفضلت به

أكثر من ما كنت أتمنى وأطمح للوصول إليه

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

🤲🤲🤲