استخراج تقرير بشروط

[يوسف السيد]

السلام عليكم

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

واريد نقل البيانات بدون تكرار لصفحة التقارير ولكن علي اساس اخر تحديث للحالة

الشرح والنتائج المتوقعة بالمرفق

متابعة مستخلصات.xlsx

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

اكثر من مرة أكرر اسماء الصفحات يجب ان تكون باللغة الاجنبية لحسن عمل نسخ ولصق للكود (دون مشاكل اللغة)

الكود

Option Explicit
Sub transfer_Unique()
Dim D As Worksheet, R As Worksheet
Dim RoD%, RoR%, I%, m%, ky
Dim RGD As Range, RGR As Range
Dim dic As Object, Arr

Set D = Sheets("Data"): Set R = Sheets("Repport")
Set RGD = D.Range("a2").CurrentRegion: RoD = RGD.Rows.Count
Set RGD = RGD.Offset(1).Resize(RoD - 1).Columns(11)
Set RGR = R.Range("A2").CurrentRegion: RoR = RGR.Rows.Count

 If RoR > 1 Then
 Set RGR = RGR.Offset(1).Resize(RoR - 1)
 RGR.ClearContents
 End If
Set dic = CreateObject("Scripting.Dictionary")
For I = 1 To RoD - 1
If Len(RGD.Cells(I)) > 1 Then

    Arr = Application.Transpose(D.Cells(RGD.Cells(I).Row, 1).Resize(, 11))
    Arr = Application.Transpose(Arr)
    Arr = Join(Arr, "*")
    dic(Arr) = vbNullString
 End If
 Next
 m = 3
 For Each ky In dic.keys
  R.Cells(m, 1).Resize(, 11) = Split(ky, "*")
  m = m + 1
 Next
 R.Range("A2").CurrentRegion.Value = R.Range("A2").CurrentRegion.Value
 Set dic = Nothing: Set D = Nothing: Set R = Nothing
 Set RGD = Nothing: Set RGR = Nothing
 
End Sub

الملف مرفق

 

Mostakhlasat.xlsm

[يوسف السيد]

شكرا جزيلا استاذ سليم

معلومة حضرتك بخصوص اوراق العمل سأنتبه لها جيدا ان شاء الله

ولكن بخصوص الكود استاذي الفكرة انه في شيت داتا يتم تكرار تسجيل (اسم المشروع + رقم المستخلص) في كل مرة تحدث عليه حركة جديدة اثناء المتابعة

وينتقل للتقرير فقط اخر حركة علي رقم المستخلص+اسم المشروع حسب التاريخ الاحدث والاخير في عمود تاريخ الحالة

حيث ان المشروع له تقريبا 36 مستخلص وتتغير الارقام لتدل علي كل مستخلص بالمشروع

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

واكرر شكري مرة اخري

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

تم التعديل على الكود

Sub transfer_Unique_New()
Dim D As Worksheet, R As Worksheet
Dim RoD%, RoR%, I%, m%, ky
Dim RGD As Range, RGR As Range
Dim Arr_1, Arr_2, Arr_3
Dim dic_1 As Object
Dim dic_2 As Object
Dim dic_3 As Object

Set D = Sheets("Data"): Set R = Sheets("Repport")
Set RGD = D.Range("a2").CurrentRegion: RoD = RGD.Rows.Count
Set RGD = RGD.Offset(1).Resize(RoD - 1).Columns(11)
Set RGR = R.Range("A2").CurrentRegion: RoR = RGR.Rows.Count
Set dic_1 = CreateObject("Scripting.Dictionary")
Set dic_2 = CreateObject("Scripting.Dictionary")
Set dic_3 = CreateObject("Scripting.Dictionary")
 If RoR > 1 Then
 Set RGR = RGR.Offset(1).Resize(RoR - 1)
 RGR.ClearContents
 End If

For I = 1 To RoD - 1
If Len(RGD.Cells(I)) > 1 Then
  x = RGD.Cells(I).Row

    Arr_1 = Application.Transpose(D.Cells(x, 1).Resize(, 3))
    Arr_1 = Application.Transpose(Arr_1)
    Arr_1 = Join(Arr_1, "*")
    ''''''''''''''''''''''''''''''''

    Arr_2 = Application.Transpose(D.Cells(x, 4).Resize(, 6))
    Arr_2 = Application.Transpose(Arr_2)
    Arr_2 = Join(Arr_2, "*")
    '+++++++++++++++++++++++++++++++

    Arr_3 = Application.Transpose(D.Cells(x, "j").Resize(, 2))
    Arr_3 = Application.Transpose(Arr_3)
    Arr_3 = Join(Arr_3, "*")
    
    dic_1(RGD.Cells(I).Value) = Arr_1
    dic_2(RGD.Cells(I).Value) = Arr_2
    dic_3(RGD.Cells(I).Value) = Arr_3
 End If
 Next
 m = 3
 For Each ky In dic_1.keys
  R.Cells(m, 1).Resize(, 3) = Split(dic_1(ky), "*")
  m = m + 1
 Next
 m = 3
 For Each ky In dic_2.keys
  R.Cells(m, 4).Resize(, 6) = Split(dic_2(ky), "*")
  m = m + 1
 Next
  m = 3
 For Each ky In dic_3.keys
  R.Cells(m, 10).Resize(, 2) = Split(dic_3(ky), "*")
  m = m + 1
 Next
 R.Range("A2").CurrentRegion.Value = R.Range("A2").CurrentRegion.Value
 Set dic_1 = Nothing: Set dic_2 = Nothing: Set dic_3 = Nothing
 Set D = Nothing: Set R = Nothing
 Set RGD = Nothing: Set RGR = Nothing
 
End Sub

الملف من جديد

 

Mostakhlasat_New.xlsm

[يوسف السيد]

حياك الله استاذ سليم

شكرا جزيلا علي الكود الرائع

وزادكم الله علما ونفع بكم

[أحمد يوسف]

أستاذ يوسف السيد

فين الإعجاب لكل هذه الإجابات الممتازة ؟!!💙