رجب جاويش

تفضل أخى تم فصل الكود الى كودين كما تريد ترحيل بيانات.rar

على شكر على واجب أخى كمال شكا جزيلا أخى الحبيب حماده عمر أبو سما لك وحشة والله

على شكر على واجب أخى الفاضل

جزاكم الله خيرا إخوتى الأفاضل وان شاء الله يتم تطوير البرنامج لتبية كل الاحتياجات وتنفيذ كل الملاحظات

أخى مهند هذا هو شرح كود الاخفاء Sub ragab() 'تعريف المتغيرات Dim rng As Range Dim cl As Range Dim LC As Integer 'ايقاف اهتزاز الشاشة لتسريع الكود Application.ScreenUpdating = False 'تحديد رقم آخر عمود فارغ فى الصف الأول LC = Range("A1").End(xlToRight).Column 'تحديد المدى بالخلايا المحتوية على المجموع فى الصف الحادى عشر Set rng = Range(Cells(11, 2), Cells(11, LC)) 'حلقة تكرارية لمعرفة الخلايا المحتوية على القيمة صفر فى المجموع For Each cl In rng If cl.Value = 0 Then 'اخفاء عمود الخلايا المحتوية على صفر cl.EntireColumn.Hidden = True End If Next ' ارجاع اهتزاز الشاشة Application.ScreenUpdating = True End Sub وبالنسبة لكود الاظهار فهو يقوم بالعملية العكسية

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

أخى ياسر أخى شبكة النبراس الإسلامية الكود يعمل عندى بشكل ممتاز تسلم ايديك أخى ياسر أنا اعمل على أوفيس 2010

أخى الفاضل جرب هذا الكود لعله يكون كما تريد Sub نقل() Dim Rng1 As Range, Rng2 As Range Dim LastRow2 As Long, LastRow3 As Long Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet '=========================================================== Set sh1 = Sheets("B"): Set sh2 = Sheets("D") Set sh3 = Sheets("Archive") Set Rng1 = sh1.Range("D8:BM39") Set Rng2 = sh1.Range("A40:BL40") '=========================================================== Application.ScreenUpdating = False LastRow2 = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1 LastRow3 = sh3.Range("A" & Rows.Count).End(xlUp).Row + 1 '=========================================================== Rng1.Copy sh3.Range("A" & LastRow3).PasteSpecial Paste:=xlPasteValues Rng2.Copy sh2.Range("A" & LastRow2).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False Application.ScreenUpdating = True End Sub ترحيل بيانات.rar

لا شكر على واجب يا باشا

السلام عليكم تفضل أخى كود الاخفاء Sub ragab() Dim rng As Range Dim cl As Range Dim LC As Integer Application.ScreenUpdating = False LC = Range("A1").End(xlToRight).Column Set rng = Range(Cells(11, 2), Cells(11, LC)) For Each cl In rng If cl.Value = 0 Then cl.EntireColumn.Hidden = True End If Next Application.ScreenUpdating = True End Sub وهذا كود الاظهار Sub ragab1() Dim rng As Range Dim LC As Integer Application.ScreenUpdating = False LC = Range("A1").End(xlToRight).Column Set rng = Range(Cells(11, 2), Cells(11, LC)) rng.EntireColumn.Hidden = False Application.ScreenUpdating = True End Sub Book2.rar

أخى الفاضل يوجد مشكلة فى تحميل الملف المرفق برجاء ارفاقه مره أخرى

جزاك الله خيرا أخى ياسر فعلا موضوعات مميزة ومفيدة للجميع تقبل تحياتى

الأستاذ المتميز المبدع / ياسر العربى جزاك الله خيرا على هذه الشروحات المتميزة التى تفيد كل أعضاء المنتدى جعلها الله فى ميزان حسناتك تقبل أرق تحياتى وتقديرى

تفضل أخى علما بان اسم المستخدم ragab وكلمة المرور 123 ويمكنك تغيرهما من الخلايا AZ1 و AZ2 من الصفحة الأولى prchi Raspi Food Cost 1.rar

أخى الفاضل تم اصلاح بعض الأخطاء الصغيرة الموجودة فى الكود لكى يعمل بشكل صحيح أما طبيعة المهمة التى يقوم بها الكود فأنت أدرى بها أما بالنسبة لطلبك الثانى يرجى توضيحة جيدا الفواتير1.rar

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

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

أخى محمد جرب الكود التالى Sub ragab() Dim rng As Range Dim rng1 As Range Dim cl As Range On Error Resume Next Application.ScreenUpdating = False Set rng = Range("c13:c65512").SpecialCells(xlCellTypeBlanks) rng.EntireRow.Hidden = True Set rng1 = Range("c13:c65512").SpecialCells(xlCellTypeVisible) For Each cl In rng1 If cl.Value = 0 Then cl.EntireRow.Hidden = True End If Next Application.ScreenUpdating = True End Sub الخزينة.rar

جزاك الله خيرا أخى ابراهيم على هذا الدعاء الطيب

أخى الفاضل الأستاذ / مختار حسين جزاك الله كل خير على هذا المرور العطر

أعلى الله من قدرك أخى الحبيب ياسر بسبب هذا التواضع الذى هو من شيم العظماء

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

أخى ياسر بجد والله أنا اقف مبهورا أمام ابداعاتك لأتعلم منها وفعلا فكرة جميلة فكرة النقاش لتبادل الخبرات وبالنسبة للكود ما رأيك فى هذا الاختصار Sub ragab() Set Sh = ورقة3 x = [g13] T = Application.Match(x, Sh.Columns("G:G"), 0) If Not IsNumeric(T) Then T = Sh.[G1000].End(xlUp).Row + 1 Sh.Range("B" & T).Resize(1, 10).Value = Range("B13").Resize(1, 10).Value End Sub

شكرا لك أخى الفاضل مهند وجزاك الله خيرا

أخى الحبيب / ابراهيم جزاك الله كل خير على هذه الكلمات الطيبة والشعور الطيب والله المنتدى كله واحشنى جدا وربنا يديم المعروف والمودة