خطأ في كود vba

[yasser_w_2010]

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

1 - نقل الصف بالكامل المكتوب في خليه كلمة ( منتهي ) الى الشيت الاخر في اخر صف فارغ الذي يسبقه بيانات 

2 - حذف الصف كامل بعد الترحيل

شاكر لكم جدا .... تـــم تعديل رفع الملف بدون حماية

11.xlsm

[عبدالفتاح في بي اكسيل]

جرب هذا  الماكرو 

Sub MOVEROWS()

lastrow = Worksheets("data").UsedRange.Rows.Count
lastrow2 = Worksheets("save").UsedRange.Rows.Count
If lastrow2 = 1 Then
    lastrow2 = 0
    Else
End If
Do While Application.WorksheetFunction.CountIf(Range("Q:Q"), "منتهي") > 0
    Set Check = Range("Q1:Q" & lastrow)
    For Each Cell In Check
        If Cell = "منتهي" Then
            Cell.EntireRow.Copy Destination:=Worksheets("SAVE").Range("A" & lastrow2 + 1)
            Cell.EntireRow.Delete
            lastrow2 = lastrow2 + 1
            Else:
        End If
    Next
Loop
End Sub

 

[عبدالفتاح في بي اكسيل]

يرحل  ويحدف  انزل  لاخر    الورقة وسترى  البيانات   لا ادري  يوجد  مشكلة  في  التنسيق 

لم  يعجبني   تنسيقك  في  الاعلى   يوجد  تنسيقات  جدول  ثم  فراغات  ثم  في  الاسفل  😕  

[yasser_w_2010]

ارجو المساعدة من الاساتذه الكرام

عند عمل ترحيل للصفوف بناء على عامود ( منتهي ) الكود في عامود ارقام الغرف لا يعمل

ارجو التعديل على الكود بحيث عند ترحيل الصفوف يعمل  في شيت data و شيت save

هوه ده الكود عند ترحيل الصف لا يعمل

Function Combine(WorkRng As Range, Optional Sign As String = "~") As String
Dim Rng As Range
Dim OutStr As String
For Each Rng In WorkRng
    If Rng.Text <> " " Then
        OutStr = OutStr & Rng.Text & Sign
    End If
Next
Combine = Left(OutStr, Len(OutStr) - 1)
End Function

1.xlsm

[yasser_w_2010]

=Combine(Q6:DL6)

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

وعند حذف الصف الكود بيجيب خطاء

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