ترحيل البيانات بشرط التجميع

[ibn_egypt]

السادة الأفاضل

لدي شيتين الأول مخصص لإدخال البيانات والثاني لترحيل البيانات إليه

 

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

 

مرفق ملف للتوضيح

وشاكر لكم جزيلا

T.rar

[عبدالله باقشير]

السلام عليكم

جرب الكود التالي

Sub KH_START()
Dim cel As Range
Dim LR As Integer, M As Integer, c As Integer

With ورقة2
    LR = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    M = Val(CStr(Application.Match(ورقة1.[F1], .Range("A2:A" & LR), 0)))
    If M Then
        M = M + 1
        For c = 1 To 5
            .Cells(M, c + 2).Value = Val(.Cells(M, c + 2)) + Val(ورقة1.Range("B8").Cells(1, c))
        Next
    Else
        .Cells(LR, "A").Value = ورقة1.[F1]
        .Cells(LR, "B").Value = ورقة1.[C1]
        .Cells(LR, "C").Resize(1, 5).Value = ورقة1.Range("B8:F10").Value
    End If
End With
 ورقة1.Range("C1,B8:F10").ClearContents
End Sub

المرفق 2010

T.rar

[ashraf_6770]

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

[عبدالله باقشير]

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

[ibn_egypt]

أ.عبد الله

أنا مش عارف اشكر حضرتك ازاى ... بجد هايل وهو المطلوب بالضبط

بارك الله لك في علمك استاذنا الفاضل وبارك الله لك في صحتك وأهلك ومالك وكل عام وانت بالف خير

شكرا جزيلا

[عبدالله باقشير]

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

وكل عام وانتم بخير

[ibn_egypt]

أ.عبد الله

السلام عليكم ورحمة الله وبركاته

 

انا والله مكسوف من حضرتك جدا .. بس انا كنت ناسي موضوع التاريخ كمان ... وحاولت انا اعدل في الكود بتاع حضرتك لكن لم اتمكن من الحل

 

التعديل الثاني المطلوب

ان نقارن التاريخ والصنف معا ... اذا وجد الصنف في نفس التاريخ سابقا يتم الجمع بينما اذا كان الصنف في تاريخ جديد يتم اضافته على صف جديد بعد اخر صف

 

مرفق لحضرتك الملف به الكود والتعديلات التى ادخلتها عليه .. هذا اقصي ما استطعت فعله

 

شاكر جدا مقدما

TA.rar

تم تعديل يونيو 21, 2014 بواسطه ibn_egypt

[ibn_egypt]

للتذكير أ.عبد الله

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

[عبدالله باقشير]

أ.عبد الله

السلام عليكم ورحمة الله وبركاته

 

انا والله مكسوف من حضرتك جدا .. بس انا كنت ناسي موضوع التاريخ كمان ... وحاولت انا اعدل في الكود بتاع حضرتك لكن لم اتمكن من الحل

 

التعديل الثاني المطلوب

ان نقارن التاريخ والصنف معا ... اذا وجد الصنف في نفس التاريخ سابقا يتم الجمع بينما اذا كان الصنف في تاريخ جديد يتم اضافته على صف جديد بعد اخر صف

 

مرفق لحضرتك الملف به الكود والتعديلات التى ادخلتها عليه .. هذا اقصي ما استطعت فعله

 

شاكر جدا مقدما

 

 

اضفنا عمود يمين جدول البيانات

جعلناه كمعيار للترحيل ( يمكنك اخفاءه )

 

شاهد الكود

Sub KH_START()

Dim cel As Range
Dim LR As Integer, M As Integer, C As Integer
Dim iTest As String

With Main
    iTest = .[H7].Value2 & "-" & .[B13].Value2
End With

With Products
    LR = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    M = Val(CStr(Application.Match(iTest, .Range("A2:A" & LR), 0)))
    If M Then
        M = M + 1
        For C = 1 To 6
            .Cells(M, C + 4).Value = Val(.Cells(M, C + 4)) + Val(Main.Range("C13").Cells(1, C))
        Next
    Else
        .Cells(LR, "A").Value = iTest
        .Cells(LR, "B").Value = Main.[B13]
        .Cells(LR, "C").Value = Main.[H7]
        .Cells(LR, "D").Value = Main.[C7]
        .Cells(LR, "E").Resize(1, 6).Value = Main.Range("C13:H13").Value
    End If
End With

 
End Sub

المرفق 2010

TA.rar

[ibn_egypt]

أستاذي الفاضل أ.عبد الله

 

ربنا يزيدك من فضله وعلمه ويجعلك من الفائزين برحمة الله ومغفرته والعتق من نيرانه في رمضان

 

الف مليون شكر أستاذي الكريم وكل عام وانت واهلك ومن تحب بألف خير

[عبدالله باقشير]

جزاكم الله خير
وكل عام وانتم بخير

واثابكم بدعائكم واعطاكم بمثله اضعاف مضاعفة

 

تقبلوا تحياتي وشكري