اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


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

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

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

 

Untitled.png

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

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

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

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

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

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

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

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

 

photo.png

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

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information