الترحيل حسب نوع الفاتورة دون التاثير على المعادلات الموجودة بالفاتورة

[نور وحيد]

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

بعد التحية و السلام لكل اعضاء المنتدى الكرام 

ارجوا المساعدة فى ترحيل الفاتورة حسب نوع الفاتورة سواء كان مشتروات او مبيعات او مرتجع (حسب خلية l1) دون التاثير على وجود المعادلات الموجودة بالفاتورة ذات اللون الكمونى الفاتح ثم حذف محتوى الخلايا ذات اللون الاخضر بعد الترحيل وظهور رساله نجاح الترحيل حسب نوعه

ملحوظة تم من قبل عرض الموضوع ولكن الجديد هو الاحتفاظ بالمعادلات الموجودة بعد الترحيل

ومرفق طية الملف المراد العمل عليه                                                           

دفتر حسابات 2016 - Copy.rar

[خالد الرشيدى]

اخى الكريم

جرب المرفق لعله المطلوب

 دفتر حسابات 2016 - Copy.rar

 

تم تعديل أغسطس 10, 2015 بواسطه خالد الرشيدى

[نور وحيد]

الاستاذ / خالد الرشيدى

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

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

اما بالنسبة للكود فهو يؤدى المطلوب فعلا  و انا عاجز عن الشكر ولكن ان امكن شرح الكود اكون شاكر بالاضافة الى كيفية ضغط الملف المرفوع فالملف قبل رفعة كان 429 kb اما هو الان 50 kb بعد فك الضغط عنه     

[خالد الرشيدى]

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

بخصوص شرح الكود سأضعة حال الانتهاء منه ان شاء الله

اما وعن حجم الملف فلعلى قمت بحذف بعض التنسيقات بداخلة  اثناء العمل علية

واخيراً .... الحمد لله انك قد وصلت لما تريد

[خالد الرشيدى]

اليك شرح الكود

Sub مستطيلمستديرالزوايا6_Click()
'   التعريف بالمتغيرات
Dim Ls As Long, LR As Long, u As String
'  U الموجودة بشيت الفاتورة فى المتغير  L1 تخزين قيمة الخلية
  u = Sheets("فاتوره").Range("L1")
'  كود ايجاد اخر صف بة بيانات فى صفحة الفاتورة
  Ls = Sheets("فاتوره").Cells(Rows.Count, 4).End(xlUp).Row
' U  كود ايجاد اول صف فارغ فى الصفحه المرحل اليها البيانات
  LR = Sheets(u).Cells(Rows.Count, 2).End(xlUp).Row + 1
' وقف اهتزازات الشاشة اثناء عملية التنفيذ لما يلى
   Application.ScreenUpdating = False
' اخر صف بة بيانات LS بدلالة  o  الى  B7 نسخ النطاق من
     Range("B7:O" & Ls).Copy
' U  لصق القيم المنسوخة فى اول صف فارغ فى ورقة العمل
     Sheets(u).Cells(LR, 2).PasteSpecial Paste:=xlPasteValues
' عودة الى شيت الفاتورة وتحديد النطاق المرحل ثم حذف الخلايا التى لا تحوى معادلات
      Range("B7:O" & Ls).SpecialCells(xlCellTypeConstants, 23).ClearContents
   Application.CutCopyMode = False
   Application.ScreenUpdating = True
     MsgBox ("تم بحمد الله ترحيل فاتورة " & u)
End Sub

 

[نور وحيد]

الف شكر جزاك الله خيرا