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

[أبو عبد الملك السوفي]

السلام عليكم

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

المطلوب

هو تعديل الكود 

Sub Tarheel()
'ÞÑÇÁÉ ÇáÈíÇäÇÊ ÇáÎãÓÉ ÇáÃæáí
Dim d(19)
d(1) = [g6]: d(2) = [g2]: d(3) = [g3]: d(4) = [g4]: d(5) = [b8]: d(6) = [g8]: d(7) = [C13]: d(8) = [f13]: d(9) = [C18]: d(10) = [f19]: d(11) = [C20]: d(12) = [b23]:  d(13) = [B26]: d(14) = [c26]: d(15) = [B27]: d(16) = [c27]: d(17) = [b28]: d(18) = [c28]: d(19) = [c30]



' Check if this Invoice is exist
 With Sheets("total")
    LR = .[b10000].End(xlUp).Row
        For r = 4 To LR
            x = .Cells(r, 2).Value
            If x = [g6] Then GoTo 10     ' *** Found @ r (Row)***
        Next r
    GoTo 30                              ' NOT Found

10
        MsgBox ("ÇáÝÇÊæÑÉ ãæÌæÏÉ ãä ÞÈá" & Chr(10) & "ÓíÊã ÍÐÝåÇ ãä æÑÞÉ ÇáÈíÇäÇÊ æäÞáåÇ ãßÇä ÇáÞÏíãÉ")
        If r <> LR Then n_LR = .Cells(r, 2).End(xlDown).Row - 1: GoTo 20
            n_LR = .[b10000].End(xlUp).Row
20          .Range("B" & r & ":G" & n_LR).EntireRow.Delete Shift:=xlUp
             
30
'äÞá ÇáÈíÇäÇÊ ÇáÎãÓÉ ÇáÃæáí ááæÑÞÉ ÏÇÊÇ

DR = .[b10000].End(xlUp).Row + 1         'ÂÎÑ ÕÝ ÈíÇäÇÊ ÌÇåÒ áÇÓÊáÇã ÈíÇäÇÊ ÌÏíÏÉ ÈÇáæÑÞÉ ÏÇÊÇ
    For i = 1 To 19
        .Cells(DR, i + 1) = d(i)
    Next i
End With

LR = [E31].End(xlUp).Row
'ÞÑÇÁÉ æäÞá ÇáÈíÇäÇÊ ÇáÃÑÈÚÉ ÇáÃÎíÑÉ


Sheets("mokalassa").Select
Reply = MsgBox("Êã ÊÑÍíá ÇáÝÇÊæÑÉ ÈÍãÏ Çááå" & Chr(10) & "åá ÊÑíÏ ãÓÍ ÇáÈíÇäÇÊ ãäåÇ", vbYesNo)
If Reply <> 6 Then Exit Sub
Range("g2") = [g3]
Range("g3") = "=NOW()"
Range("g4") = "=IF(HOUR(R[-1]C)>15,""ÇáãÓÇÆíÉ"",""ÇáÕÈÇÍíÉ"")"
Range("b8:e8").ClearContents
Range("g8").ClearContents
Range("c13:d13").ClearContents
Range("f13:g13").ClearContents
Range("c18:d18").ClearContents
Range("f19:g19").ClearContents
Range("c20:d20").ClearContents
[g6] = [g6] + 1
Range("b26:b28").ClearContents
Range("c26:g26").ClearContents
Range("c27:g27").ClearContents
Range("c28:g28").ClearContents
Range("c30:d30") = "=IF(R[-10]C="""","""",(R[-2]C[-1]+R[-3]C[-1]+R[-4]C[-1]+R[-10]C)-(R[-12]C+R[-17]C))"
Range("b23:c23") = "=IF(R[-3]C[1]="""","""",R[-3]C[1]-(R[-5]C[1]+R[-10]C[1]))"
End Sub

فعند الرحيل اذا كان رقم الاستمارة موجود من قبل في صفحة total فانه يرحل الى نفس السطر وليس الى اخر سطر

واضن ان الجزئية التاليه هي المقصودة بالتعديل

10
        MsgBox ("الفاتورة موجودة من قبل" & Chr(10) & "سيتم حذفها من وقة البيانت ونقلها من مكانها القديم")
        If r <> LR Then n_LR = .Cells(r, 2).End(xlDown).Row - 1: GoTo 20
            n_LR = .[b10000].End(xlUp).Row
20          .Range("B" & r & ":G" & n_LR).EntireRow.Delete Shift:=xlUp

برنامج مركز شمس للتسوق تحت التعديل.rar

تم تعديل ديسمبر 22, 2017 بواسطه أبو عبد الملك السوفي

[أبو عبد الملك السوفي]

للرفع بورك فيكم

 

[بن علية حاجي]

السلام عليكم
أخي الكريم، لقد حاولت في الملف من أول موضوع لك في المنتدى ولم أجد الفكرة ولا زلت أحاول... أودّ أن أعرف لماذا تريد أن ترحّل البيانات إلى نفس مكانها في حالة وجودها ؟ هل يمكن القيام بمسحها دون ترحيلها (وأقصد مسح البيانات الموجودة مسبقا في شيت Total)؟ 

أخوك بن علية

[بن علية حاجي]

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

أخي الكريم، جرب الملف المرفق لعل فيه ما تريد...

بن علية حاجي

برنامج مركز شمس للتسوق تحت التعديل.rar

[أبو عبد الملك السوفي]

جزاك الله خيرا استاذحاجي ونفع بك

الهدف من الترحيل الى نفس السطر لان الاستمارة تملأ على مرحلتين

المرحلة الاولة تملأ الييانات الاولى في الاستمارة ثم ترحل الى total

اما المرحلة الثانية فيتم استدعاء الاستمارة واكمال المعلومات المتبيقة ثم ترحيلها

لذا يجب ان تعدل في نفس السطر ولا يتغير مكانها

والملف الاخير لم يفي بالغرض فهو ينقل الاستمارة المعدلة الى السطر ما قبل الاخير اي انه يحذف السطر الاخير وهو ليس المطلوب

منذ 3 ايام او اكثر وانا احاول في تلك الجزئيه في الكود ولم انجح

اخي سابعث لك الملف الاصلي الذي اخذت منه الكود فهو شغال وهو من اعداد الاستاذ محمود لعلك تفهم الية عمل الكود

فاتورة جديدة6.rar

تم تعديل ديسمبر 23, 2017 بواسطه أبو عبد الملك السوفي

[بن علية حاجي]

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

ألق نظرة على الملف المرفق وإن شاء الله تفي التعديلات على الكود بالغرض المطلوب...

بن علية حاجي

برنامج مركز شمس للتسوق تحت التعديل.rar

[أبو عبد الملك السوفي]

تمام

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

هذا هو المطلوب تماما....

اسال الله لك الجنه