كود ترحيل بيانات

[الشيباني1]

اخواني الاعزاء  تحية طيبه   مع اعتقادي ان الحل ليس سهلا الا انني واثق من قدرة عمالقة المنتدى على ترتيب الموضوع بخبرتهم وتفانيهم في مساعدة الآخرين .

في المرفق جدول يومي يتضمن تفاصيل حركات حسابيه ارجو المساعده بكود لترحيل هذه البيانات الى ورقتي ( in & out ) حسب الموضح فيهما

مع كل التقدير والاحترام

Book1.rar

[الشيباني1]

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

[ياسر خليل أبو البراء]

أخي الكريم الشيباني

جرب الكود التالي للترحيل إلى ورقة العمل المسماة Out .. أما بالنسبة للترحيل إلى ورقة العمل In فيحتاج لتفصيل أكثر وهل عدد الأسماء ثابتة ؟وأين بقية التفاصيل ؟ وهل هي ثابتة ؟ ...!!

Sub Test()
    Dim Ws As Worksheet, shOut As Worksheet, shIn As Worksheet
    Dim Lr1 As Long, Lr2 As Long, Lr3 As Long, lastOut As Long, lastIn As Long
    Dim I As Long, II As Long

    Set Ws = Sheet1: Set shOut = Sheet2: Set shIn = Sheet3
    Lr1 = Ws.Range("C9").End(xlDown).Row
    Lr2 = Ws.Range("C22").End(xlDown).Row
    Lr3 = Ws.Range("C36").End(xlDown).Row
    lastOut = shOut.Cells(Rows.Count, "D").End(xlUp).Row + 1
    lastIn = shIn.Cells(Rows.Count, "B").End(xlUp).Row + 1

    Application.ScreenUpdating = False
        If Lr1 = 18 Then GoTo Skipper1
        For I = 10 To Lr1
            shOut.Range("B" & lastOut).Value = Ws.Cells(3, "J").Value
            shOut.Range("D" & lastOut + II).Value = Ws.Cells(I, "C").Value
            shOut.Range("E" & lastOut + II).Value = Ws.Cells(I, "E").Value
            II = II + 1
        Next I
    
        shOut.Range("G" & lastOut).Value = Application.WorksheetFunction.Sum(shOut.Range("D" & lastOut & ":D" & lastOut + II - 1))
Skipper1:
        If Lr2 = 32 Then GoTo Skipper2
        II = 0
        For I = 23 To Lr2
            shOut.Range("I" & lastOut + II).Value = Ws.Cells(I, "C").Value
            shOut.Range("J" & lastOut + II).Value = Ws.Cells(I, "E").Value
            II = II + 1
        Next I
    
        shOut.Range("L" & lastOut).Value = Application.WorksheetFunction.Sum(shOut.Range("I" & lastOut & ":I" & lastOut + II - 1))
Skipper2:
        If Lr3 = 43 Then GoTo Skipper3
        II = 0
        For I = 37 To Lr3
            shOut.Range("N" & lastOut + II).Value = Ws.Cells(I, "C").Value
            shOut.Range("O" & lastOut + II).Value = Ws.Cells(I, "E").Value
            II = II + 1
        Next I
    
        shOut.Range("Q" & lastOut).Value = Application.WorksheetFunction.Sum(shOut.Range("N" & lastOut & ":N" & lastOut + II - 1))
Skipper3:
        shOut.Range("S" & lastOut).Value = Ws.Cells(45, "E").Value
        shOut.Range("U" & lastOut).Value = Ws.Cells(49, "C").Value
    Application.ScreenUpdating = True
End Sub

أرجو أن يفي هذا بالغرض

 

[الشيباني1]

استاذنا الرائع  اعتذر عن التأخر في الرد لسفري المفاجيء والكود بديع وجميل ومفيد جدا وارجو المساعده في بقية الطلب  اما بالنسبة للاسماء فأنا حددتها ضمن جداولها في ورقة ( in )  واي استفسار انا حاضر للايضاح  مع الشكر الجزيل

[ياسر خليل أبو البراء]

يرجى أخي الشبباني طرح موضوع جديد بطلبك الجديد مع توضيح تام للمسألة حتى تجد استجابة أفضل من إخوانك بالمنتدى

[الشيباني1]

استاذنا القدير  تحية طيبه  لدى استخدام الكود اعلاه ظهرت المشكلة التي ارفقها ضمن الملف وهي عند عدم ادخال اي من الموردين ضمن الكشف لن يظهر التاريخ عند الترحيل  وتظهر بعض البيانات ضمن العمودين ( N & O ) ارجو النظر في الموضوع  مع الشكر

ترحيل بيانات2.rar

[الشيباني1]

مازلت منتظرا لأني    لن يخيب بأذن الله ظني    

[الشيباني1]

اخواني الاعزاء  هل يمكن اجراء الترحيل بالمعادلات ؟ مع تقديري 

[الشيباني1]

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

[الشيباني1]

اخواني الاعزاء  كي لا اتهم بالالحاح هل اعتبر الموضوع منتهيا عند هذا الحد مع تقديري