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

[yara ahmed]

احتاج مساعدة اخواتى 

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

يمكن تغير فى التصميم اذا كان هناك حاجة لذلك

النتائج المرجو الحصول عليها موجودة بالمرفق

حبى وشكرى لكم

التقرير النهائى.xlsm

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

الحل هنا

Option Explicit

Sub My_Data_Sum()

      Dim Ws As Worksheet
      Dim Sheets_Names()
      Dim Client_Name()
      Dim m%, x%, n%, Ro%, K%
      Dim Rg_name As Range

tak.Cells(2, 2).Resize(500, 8).ClearContents
Ro = tak.Cells(Rows.Count, 1).End(3).Row
m = -1
For Each Ws In Sheets
    If UCase(Ws.Name) Like "SH*" Then
      m = m + 1
      ReDim Preserve Sheets_Names(m): Sheets_Names(m) = Ws.Name
    End If
Next Ws

x = -1
For n = 2 To Ro
    If tak.Cells(n, 1) <> vbNullString Then
      x = x + 1
      ReDim Preserve Client_Name(x)
      Client_Name(x) = tak.Cells(n, 1)
    End If
Next n

K = 2
For x = LBound(Client_Name) To UBound(Client_Name)

 For m = LBound(Sheets_Names) To UBound(Sheets_Names)
    Set Ws = Sheets(Sheets_Names(m))
      Set Rg_name = Ws.Range("A:A").Find(Client_Name(x), lookat:=1)
       If Not Rg_name Is Nothing Then
         
         tak.Cells(K, 3).Resize(, 6).Value = _
         Rg_name.Offset(1, 1).Resize(, 6).Value
         
         tak.Cells(K, 2) = Sheets_Names(m)
         
         tak.Cells(K, "I") = _
         Application.Sum(tak.Cells(K, 3).Resize(, 6))
       
       End If
       K = K + 1
   Next m
Next x
 Erase Sheets_Names: Erase Client_Name: Set Ws = Nothing
End Sub

 

Final_repory_yara.xlsm

[yara ahmed]

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

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

الف شكر ربنا ما يحرمنى منك ابدااااااااااااااااا

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

هذا الكود للنتسيق

العامود B  في الصفحة الأولى بجب ان يكون فارغاً كلياُ (تم اخفاءه لعدم الكتابة فيه غن طريق الخطأ)

Option Explicit

Sub My_Data_Sum()

      Dim Ws As Worksheet
      Dim Sheets_Names()
      Dim Client_Name()
      Dim m%, x%, n%, Ro%, K%
      Dim Rg_name As Range
      Dim First_All As Range, MMax%
   
   Set First_All = tak.Range("C1").CurrentRegion
    MMax = First_All.Rows.Count
    If MMax > 1 Then
    First_All.Offset(1).Resize(MMax).Clear
    End If
Ro = tak.Cells(Rows.Count, 1).End(3).Row
m = -1
For Each Ws In Sheets
    If UCase(Ws.Name) Like "SH*" Then
      m = m + 1
      ReDim Preserve Sheets_Names(m): Sheets_Names(m) = Ws.Name
    End If
Next Ws
'
x = -1
For n = 2 To Ro
    If tak.Cells(n, 1) <> vbNullString Then
      x = x + 1
      ReDim Preserve Client_Name(x)
      Client_Name(x) = tak.Cells(n, 1)
    End If
Next n
'
K = 2
For x = LBound(Client_Name) To UBound(Client_Name)

 For m = LBound(Sheets_Names) To UBound(Sheets_Names)
    Set Ws = Sheets(Sheets_Names(m))
      Set Rg_name = Ws.Range("A:A").Find(Client_Name(x), lookat:=1)
       If Not Rg_name Is Nothing Then

         tak.Cells(K, 4).Resize(, 6).Value = _
         Rg_name.Offset(1, 1).Resize(, 6).Value

         tak.Cells(K, 3) = Sheets_Names(m)

         tak.Cells(K, "J") = _
         Application.Sum(tak.Cells(K, 4).Resize(, 6))

       End If
       K = K + 1
   Next m
Next x

If K > 2 Then
 With tak.Range("C2").Resize(K - 1, 8)
  .Borders.LineStyle = 1
  .HorizontalAlignment = 3
  .Font.Bold = True
  .Font.Size = 14
 End With
   
 With tak
   .Cells(K, 3) = "Sum"
    .Cells(K, 4).Resize(, 7).Formula = _
   "=SUM(D2:D" & K - 1 & ")"
     .Cells(K, 3).Resize(, 7) _
     .Interior.ColorIndex = 40
     .Cells(K, "J").Interior.ColorIndex = 3
     .Cells(K, "J").Font.ColorIndex = 2

       With .Range("C1").CurrentRegion
        .Value = .Value
        For x = 2 To K
         If .Cells(x, 1).Offset(, -2) <> "" Then
        .Cells(x, 1).Resize(, 8).Interior.ColorIndex = 35
        End If
        Next
      End With
   
 End With
End If
 Erase Sheets_Names: Erase Client_Name
 Set Rg_name = Nothing: Set First_All = Nothing
 Set Ws = Nothing
End Sub

Final_report_yara.New.xlsm

[yara ahmed]

الله يعزك بين العباد هذا ضرب من الخيال والله انت مدهش ربنا يبارك لك فى حياتك يارب

كل شئ ممتاز

ربنا يسلمك يارب من اى شر 

ويديك الصحة والعافية ودائما فى تقدم يارب

انا متشكرة جداااااااااااااااااااااااااااااااااااااااااااا