اذهب الي المحتوي
أوفيسنا

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


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

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

السلام عليكم

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

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

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

متابعة مستخلصات.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

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

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

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

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

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

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

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

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

image.png.979d88edb14a06409137401cdcb1fb7f.png

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

  • أفضل إجابة

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

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

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

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