تعديل كود للحفظ فى الارشيف

[ابو حمادة]

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

ارجو المساعدة

يوجد فى هذا الملف كود لنقل البيانات المكتوب امامها حرف (M) فى العمود (H)

وينقلها من صفحة  (add) الى صفحة (ArchiveS)

ويعمل بطريقه جيدة وصحيحه

ولكن بيمسح البيانات الموجوده فى صفحة (ArchiveS)وينسخ مكانها البيانات الجديده

المطلوب ان ينسخ البيانات اسفل البيانات السابقه فى صفحة (ArchiveS)

ويترك البيانات السابقه بها بحيث احتفظ باي بيانات تم نقلها

BookC.rar

 

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

[ابو حمادة]

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

هل من مجيب

Sub KH_START1()
Dim R As Integer
Dim Q As Range
    Dim sh As Worksheet: Set sh = Worksheets("add")
    Dim ws As Worksheet: Set ws = Worksheets("ArchiveS")
    Dim Lr As Long: Lr = sh.Cells(Rows.Count, "B").End(xlUp).Row
        
   ' ws.Range("A4:E" & Lr).ClearContents
    M = 3
    Application.ScreenUpdating = False
    For R = 6 To 506
        If sh.Cells(R, "H") = "M" Then
            M = M + 1
            sh.Range("A" & R).Range("A1:D1").Copy
        With ws
                   'هذا السطر محتاج تعديله حتى يتم نسخ البيانات دون مسح البيانات السابقه'
                ws.Range("A" & M).PasteSpecial xlPasteValues
                ws.Range("A" & M) = M - 3
             
             End With
             End If
    Next
    Application.ScreenUpdating = True
   
End Sub

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

 

[ابراهيم الحداد]

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

استبدل الكود السابق بهذا الكود وهو نفس الكود السابق بعد التعديل

Sub KH_START1()
Dim R As Integer ', i As Integer, n As Integer, s As Integer
Dim Q As Range
    Dim sh As Worksheet: Set sh = Worksheets("add")
    Dim ws As Worksheet: Set ws = Worksheets("ArchiveS")
    Dim Lr As Long: Lr = sh.Cells(Rows.Count, "B").End(xlUp).Row
    Dim Ls As Long: Ls = ws.Cells(Rows.Count, "B").End(xlUp).Row
m = 3
    Application.ScreenUpdating = False
    For R = 6 To 506
        If sh.Cells(R, "H") = "M" Then
            m = m + 1
            sh.Range("A" & R).Range("A1:D1").Copy 'تحديد الاعمدة المراد نسخها'
        With ws
           'هذا السطر لنسخ البيانات  محتاج تعديل هذا السطر ليتم النسخ بعد اخر صف به بيانات ويترك البيانات السابقه  '
                
                
                ws.Range("A" & m + Ls - 3).PasteSpecial xlPasteValues
                ws.Range("A" & m + Ls - 3) = m + Ls - 6 'تسلسل'
             End With
             End If
    Next
    Application.ScreenUpdating = True
End Sub

 

[ابو حمادة]

3 ساعات مضت, زيزو العجوز said:

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

استبدل الكود السابق بهذا الكود وهو نفس الكود السابق بعد التعديل

Sub KH_START1()
Dim R As Integer ', i As Integer, n As Integer, s As Integer
Dim Q As Range
    Dim sh As Worksheet: Set sh = Worksheets("add")
    Dim ws As Worksheet: Set ws = Worksheets("ArchiveS")
    Dim Lr As Long: Lr = sh.Cells(Rows.Count, "B").End(xlUp).Row
    Dim Ls As Long: Ls = ws.Cells(Rows.Count, "B").End(xlUp).Row
m = 3
    Application.ScreenUpdating = False
    For R = 6 To 506
        If sh.Cells(R, "H") = "M" Then
            m = m + 1
            sh.Range("A" & R).Range("A1:D1").Copy 'تحديد الاعمدة المراد نسخها'
        With ws
           'هذا السطر لنسخ البيانات  محتاج تعديل هذا السطر ليتم النسخ بعد اخر صف به بيانات ويترك البيانات السابقه  '
                
                
                ws.Range("A" & m + Ls - 3).PasteSpecial xlPasteValues
                ws.Range("A" & m + Ls - 3) = m + Ls - 6 'تسلسل'
             End With
             End If
    Next
    Application.ScreenUpdating = True
End Sub

 

شكرا لاهتمامك استاذي الغالى 

زيزو العجوز

انا استبدلت الكود ولكن لايعمل

لا يتم نقل اي بيانات

[ابو حمادة]

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

الكود صعب ولا مافيش حد هنا

اتمنى القى حد من خبراء الاكسل يساعدني 

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

 

[ابراهيم الحداد]

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

الكود يعمل لدى بمنتهى الكفاءة و هذا هو الدليل

اليك الملف 

 

BookC.rar

[ابو حمادة]

4 دقائق مضت, زيزو العجوز said:

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

الكود يعمل لدى بمنتهى الكفاءة و هذا هو الدليل

اليك الملف 

 

BookC.rar

كدا شغال تمام استاذي الغالي

اجمل تحيه وتقدير مني اليك

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

ليا استفسار 

السطر دا ممكن شرح ليه خصوصا -6

                ws.Range("A" & M + Ls - 3) = M + Ls - 6