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

[احمد محمد العباسى]

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

كنت محتاج اعمل كود ترحيل لفاتوره وبعد ما تترحل امسح بياناتها بس المشكله لما بنقلها المعادلات اللى ف الفاتوره بتترحل هى كمان فعايزها تتنقل كنصوص مش معادلات 

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

أخي الكريم أحمد

أهلاً بك في المنتدى ونورت بين إخوانك ..

يرجى تغيير اسم الظهور للغة العربية كما يرجى الإطلاع على موضوع التوجيهات في الموضوعات المثبتة في صدر المنتدى

 

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

إليك مثال مبسط فيه خليتين أحدهما B5 خلية بها نص وليست معادلة ، والخلية الأخرى D5 هي معادلة

يتم الترحيل للخليتين ثم بعد الترحيل يتم مسح الخلية التي بها نص أما الخلية التي بها معادلة فلا يتم مسح بياناتها

أرجو أن يكون المطلوب

Sub Tarhil()
    Dim WS As Worksheet, SH As Worksheet, LR As Integer, Cel As Range
    Set WS = Sheet1: Set SH = Sheet2
    LR = SH.Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    SH.Cells(LR, "A").Value = WS.Cells(5, "B").Value
    SH.Cells(LR, "B").Value = WS.Cells(5, "D").Value
    
    For Each Cel In Range("B5,D5")
        If Not Cel.HasFormula Then Cel.ClearContents
    Next Cel
End Sub

تقبل تحياتي

ClearContents For Constants Only YasserKhalil.rar

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

أخي الكريم أحمد محمد

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

تقبل تحياتي

[احمد محمد العباسى]

معلش اعذرنى انا اول مره اشترك فى منتدى 

شركه العباسى.zip

تم تعديل يناير 2, 2016 بواسطه احمد محمد العباسى
اضافه مرفقات

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

أخي الكريم أحمد

لابد من تفصيل الأمر قليلاً .. يعني أنت حددت الأعمدة المراد ترحيلها (الصنف وا لسعر والإجمالي) هل هذا فقط ما تريد ترحيله ؟؟

ما هي ورقة العمل المراد الترحيل إليها ؟ وما هي شكل المخرجات .. وما هي الخلايا التي تريد مسحها خلاف الخلايا التي بها معادلات ؟؟

 

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

أخي الكريم أحمد محمد العباسي

إليك الكود التالي كما طلبت

Sub Tarhil()
    Dim WS As Worksheet, SH As Worksheet, LR1 As Integer, LR2 As Integer, Cel As Range
    Set WS = Sheet11: Set SH = Sheet6
    LR1 = WS.Cells(86, "G").End(xlUp).Row
    LR2 = SH.Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    
    If LR1 < 8 Then MsgBox "There Is No Data", 64: Exit Sub
    
    Application.ScreenUpdating = 0
        WS.Range("G8:K" & LR1).Copy
        SH.Range("A" & LR2).PasteSpecial xlPasteValues
        
        If MsgBox("هل تريد مسح محتويات الفاتورة بعد أن تم الترحيل؟", vbQuestion + vbYesNo) = vbYes Then
            For Each Cel In WS.Range("G8:K" & LR1).SpecialCells(xlCellTypeConstants)
                Cel.ClearContents
            Next Cel
            WS.Range("K35,K37").ClearContents
        Else
            MsgBox "لم يتم مسح محتويات الفاتورة بعد الترحيل", 64
        End If
    Application.CutCopyMode = False
    Application.ScreenUpdating = 1
End Sub

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

جرب الملف وأعملنا بالنتيجة

 

شركه العباسى.rar

[احمد محمد العباسى]

انا عاجز عن الشكر ربنا يجعلها فى ميزان حسناتك 

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

أخي الكريم أحمد محمد العباسي

إنت مش عاجز عن الشكر وتقدر تقول "جزاكم الله خيراً" ، وبهذه الكلمة تكون قد وفيتني حقي .. وتقبل الله منك دعائك وكان لك نصيب منه

ونورت المنتدى وبرجاء الإطلاع على موضوع التوجيهات (كلف نفسك 10 دقايق) عشان تقدر تتعامل مستقبلاً مع المنتدى بشكل أفضل

تقبل تحياتي

[احمد محمد العباسى]

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