تعديل على كود جلب التاريخ والبيانات بدون تكرار

[مهند محسن]

السلام عليكم اساتذتى الأحباء
بارك الله فيك استاذ أبو نور على هذا العمل الممتاز-ولكن عند عمل بعض التعديلات ظهرت معى بعض المشاكل عند تنفيذ الكود وهو عدم تطابق المجموع النهائى مع ما هو وارد بالعمود J من صفحة Data  
كما حدث خطأ اخر وهو عدم ظهور الأسعار كما بالسابق فى العمودين E & F من صفحة Excursion

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

 

جلب بيانات بالتاريخ دون تكرار 2.xlsm

[مهند محسن]

ارجو من حضراتكم المساعدة فأيضا كانت هناك مشاركة وعمل مميز وكود رائع فى هذا الموضوع ايضا لأستاذنا الكبير المتألق دائما والساعى  دائما الى مساعدة كل من يحتاج الى المساعدة سليم حاصبيا له منا كل المحبة والإحترام وجزاه الله كل خير ورحم الله والديه ووسع الله فى رزقه وبارك الله دائما وابدا فى اولاده

[مهند محسن]

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

[مهند محسن]

للرفع أكرمكم الله

[مهند محسن]

للرفع بارك الله فيكم

[مهند محسن]

لسلام عليكم وهذه ايضا شكل النتائج المطلوب جلبها بالضبط  كمثال فى يوم 01/03/2019
رجاءا المساعدة بارك الله فيكم جميعا

 

[مهند محسن]

هذا هو الكود المطلوب التعديل عليه 

Sub Unqu()
Application.Calculation = xlCalculationManual
lr = Range("a" & Rows.Count).End(xlUp).Row
If lr < 4 Then lr = 4
'Range("a4:k" & lr).Cells.Interior.Color = xlNone
Range("a4:k" & lr).ClearContents
ReDim arr(1 To 1000, 1 To 11)
v = 2
For d = 1 To 31
lr = Sheets("Data").Range("c" & Rows.Count).End(xlUp).Row
For r = 2 To lr
If Day(Sheets("Data").Range("c" & r)) = d Then
arr(v, 1) = Sheets("Data").Range("c" & r)
arr(v, 2) = Sheets("Data").Range("b" & r)
arr(v, 3) = WorksheetFunction.SumIfs(Sheets("Data"). _
Range("d:d"), Sheets("Data").Range("c:c"), arr(v, 1), _
Sheets("Data").Range("b:b"), arr(v, 2))
arr(v, 4) = WorksheetFunction.SumIfs(Sheets("Data"). _
Range("e:e"), Sheets("Data").Range("c:c"), arr(v, 1), _
Sheets("Data").Range("b:b"), arr(v, 2))
a = WorksheetFunction.Weekday(arr(v, 1))
If (arr(v, 1) <> "" And arr(v, 2) = "Grand Aquarium" And a = 3) _
Or (arr(v, 1) <> "" And arr(v, 2) = "Grand Aquarium" And a = 7) Then
arr(v, 5) = 40
arr(v, 6) = 20
Else
'arr(v, 5) = WorksheetFunction.VLookup(arr(v, 2),
'Sheets("Price").Range("a3:c216"), 2, 0)
'arr(v, 6) = WorksheetFunction.VLookup(arr(v, 2), _
'Sheets("Price").Range("a3:c216"), 3, 0)
End If
b = WorksheetFunction.SumIfs(Sheets("Data").Range("j:j"), _
Sheets("Data").Range("c:c"), arr(v, 1), Sheets("Data"). _
Range("b:b"), arr(v, 2))
c = arr(v, 3) * arr(v, 5)
f = arr(v, 4) * arr(v, 6)
If c + f < b Then
arr(v, 7) = b - (c + f)
arr(v, 8) = c + f + arr(v, 7)
Else
arr(v, 8) = c + f
End If
t = t + arr(v, 8)
If arr(v, 1) <> Empty Then
arr(v, 9) = WorksheetFunction.SumIfs(Sheets("Data").Range("i:i"), _
Sheets("Data").Range("c:c"), arr(v, 1), Sheets("Data"). _
Range("b:b"), arr(v, 2))
End If
If arr(v, 8) > b And arr(v, 1) <> Empty Then
arr(v, 10) = arr(v, 8) - b
End If
If arr(v, 1) = arr(v - 1, 1) And arr(v, 2) = arr(v - 1, 2) Then
For m = 1 To 10
arr(v, m) = Empty
Next
v = v - 1
t = t - arr(v, 8)
End If
v = v + 1
End If
Next
If arr(v - 1, 1) <> Empty Then
For Z = 1 To 10
arr(v, Z) = Empty
Next
arr(v, 11) = t
t = 0
v = v + 1
End If
Next
For Z = 1 To 10
arr(1, Z) = Cells(3, Z)
Next
Range("a3").Resize(v - 1, 11) = arr
Range("b" & v + 2).FormulaR1C1 = "Total"
Range("h" & v + 2).FormulaR1C1 = "=SUBTOTAL(9,R4C8:R[-1]C)"
Range("i" & v + 2).FormulaR1C1 = "=SUBTOTAL(9,R4C9:R[-1]C)"
Range("j" & v + 2).FormulaR1C1 = "=SUBTOTAL(9,R4C10:R[-1]C)"
Range("k" & v + 2).FormulaR1C1 = "=Sum(RC[-3]-RC[-1])"
'Range("k" & v + 2).FormulaR1C1 = "=SUBTOTAL(9,R4C8:R[-1]C[-3])-SUBTOTAL(9,R4C10:R[-1]C[-1])"
Sheets("Tra. Exc ").Activate
Range("G6").FormulaR1C1 = "=Excursion!R" & v + 2 & "C9"
'Range("G6").Value = Sheets("Excursion").Range("I" & v + 2).Value
Application.Calculation = xlCalculationAutomatic
Sheets("Excursion").Activate
End Sub

وهذا هو ملف مصغر به شكل النتائج بالضبط في يوم 01/03/2019 فياريت أتمنى المساعدة على اخراج النتائج على نفس هذا الشكل وجزاكم الله كل خير وبارك الله فيكم جميعا على المساعدة

 

جلب بيانات بالتاريخ دون تكرار 2 - Copy.xlsm

[مهند محسن]

أتمنى ان يكون هناك حل بارك الله فيكم جميعا

[مهند محسن]

للرفع رفع الله قدركم

[مهند محسن]

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

تم تعديل مارس 13, 2019 بواسطه مهند محسن

[مهند محسن]

بارك الله فيكم جميعا ارجو المساعدة ولا لا يوجد حل ؟

[مهند محسن]

للرفع بارك الله فيكم جميعا

[مهند محسن]

يارب يكون هناك مساعدة بارك الله فيكم جميعا

[مهند محسن]

بارك الله فيكم جميعا أساتذتى الكرام وجعله الله فى ميزان حسناتكم 
باختصار ان اريد ضبط الكود فكان فى البداية يعمل معى بكل كفاءة وهو من أعمال استاذى الكريم ابو نور -فكل ما اريده هو جلب كل التواريخ ببياناتها من صفحة Data ووضعها وترحيلها الى صفحة Excursion بنفس الشكل الذى تم رفعه سابقا وقد تم رفع نتائج يوم 01/03/2019 بالضبط كمثال لما هو مطلوب فأرجو جلب البيانات بهذه الطريقة فى كل الأيام بحيث تنطبق لما هو وارد بصفحة Data
جعله الله فى ميزان حسناتكم وغفر الله لكم جميعا
فكما ترى أساتذتى الكرام عند تنفيذ الكود تظهر هذه الرسالة وايضا ايظهر تكرار بيانات فى اليوم الواحد كما ترى حضرتك بالصورة

 

تم تعديل مارس 14, 2019 بواسطه مهند محسن

[مهند محسن]

للرفع بارك الله فيكم جميعا

[مهند محسن]

اليس هناك حل ؟
بارك الله فيكم

[مهند محسن]

أتمنى ان يكون هناك مساعدة وحل

[مهند محسن]

للرفع أكرمكم الله

[مهند محسن]

هل هناك حل ؟

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

[مهند محسن]

للرفع بارك الله فيكم جميعا عندى امل في الحل ان شاء الله

[مهند محسن]

للرفع أكرمكم الله

[مهند محسن]

للرفع أكرمكم الله