الـعيدروس

سلمت الانامل التي خطت هذه المشاركة الاخ الاستاذ سعد عابد لك من كل الحب والتقدير تقبل مروري

تفضل لعله يفيد هذا الشرح على الكود Sub so() Application.ScreenUpdating = False On Error Resume Next 'تحديد رؤس الاعمدة التي تحتوي البيانات للفلترة Range("a1:m1").AutoFilter ' فلترة حسب اللون الذي محدد في التنسيق الشرطي من اول خليه الى الخلية 2000 Sheets("sheet1").Range("$A$1:$M$2000").AutoFilter Field:=2, Criteria1:=RGB(255, _ 199, 206), Operator:=xlFilterCellColor ' وهذا بحث عن كلمة NAME وتحديد الخلية Cells.Find(What:="Name", After:=[a1], SearchDirection:=xlPrevious).Select ' تحديد صف الخلية row_1 = ActiveCell.Row ' تقليص التحديد من خلية a2 الى عمود m وعمل نسخ Range("a2" & row_1 & ":m" & row_1).Copy ' لصق التحديد في خلية a3 sheet2 Sheets("Sheet2").Range("a3").PasteSpecial Paste:=xlPasteAll 'الغاء الفلترة بعد عملية اللصق Sheets("Sheet1").Range("a1:m1").AutoFilter Field:=2 ' لالغاء التحديد التابع للنسخ Application.CutCopyMode = False Application.ScreenUpdating = True ' تحديد شيت التقرير الذي هو sheet2 Sheets("Sheet2").Select ' لحذف الاعمدة التي دون A,B,F Sheets("Sheet2").Range("c:c,d:d,e:e,g:g,h:h,i:i,j:j,k:k,l:l,m:m").Delete ' تلاْم البيانات في عمود C sheet2 Columns("c:c").AutoFit ' تحديد المدى الذي فيه بيانات في sheet2 لعمل معاينة للطباعه ER = WorksheetFunction.CountA(Range("a:f")) + 1 RN = "A2:m" & ER Sheets("Sheet2").Range(RN).PrintOut Copies:=1, Preview:=True, Collate:=True Application.ScreenUpdating = False ' بعد اغلاق المعاينة يتم مسح التقرير Range("a3:m" & Rows.Count).Clear ' الرجوع الى Sheet1 Sheets("Sheet1").Select Application.ScreenUpdating = True Application.Calculation = xlCalc End Sub

غريب طيب تفضل جرب المرفق DATA_RFRE.rar

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

السلام عليكم تفضل لفتح الفورم اضغط F4 11.rar

الف الف مبروك يتربا في عزك ان شاء الله

تفضل Book3.alidroos.rar

اذا لم يزبط معك بعذ حذف الصف المعني ضيف هاذان السطرين في اول الكود On Error Resume Next Dim FORMAT As Variant

الاستاذ الحبيب يحياوي انت مبدع كالعادة الى الامام

بورك فيكم ياعمالقة

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

السلام عليكم اخي الفاضل استعن بهذا الكود لحذف الصفوف الفارغه وتحديد البيانات وبالنسبة للتذيل ماتشرفو به الاساتذه مع هذا سيتم ماطلبت تفضل Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long With Application .Calculation = xlCalculationManual .ScreenUpdating = False For i = Selection.Rows.Count To 1 Step -1 If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then Selection.Rows(i).EntireRow.Delete End If Next i .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With Application.ScreenUpdating = False Application.EnableEvents = False Dim thded As HPageBreak Dim rngCol As Range Dim arow As Range On Error Resume Next For Each thded In ActiveWindow.SelectedSheets.HPageBreaks thded.Delete Next thded Set rngCol = ActiveSheet.Range("a5:b" & Cells(Rows.Count, "b").End(xlUp)) Do Set arow = rngCol(1) Set rngCol = rngCol.ColumnDifferences(Comparison:=arow) rngCol.Select ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Range("a5").End(xlDown).Offset(2, 0) Loop Until arow = rngCol(1) Application.ScreenUpdating = True Application.EnableEvents = True End Sub

السلام عليكم استاذي الحبيب عبدالله المجرب هكذا بيكون حسب عمود a:f اخر خليه فيها بيانات في كلا هذه الاعمدة يقوم يتعمدها كتحديد للطباعة والله اعلم Private Sub Worksheet_Change(ByVal Target As Range) Dim thded As HPageBreak Dim rngCol As Range Dim arow As Range On Error Resume Next For Each thded In ActiveWindow.SelectedSheets.HPageBreaks thded.Delete Next thded Set rngCol = ActiveSheet.Range("a2:f" & Cells(Rows.Count, "a:f").End(xlUp)) Do Set arow = rngCol(1) Set rngCol = rngCol.ColumnDifferences(Comparison:=arow) rngCol.Select ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Range("a2").End(xlDown).Offset(2, 0) Loop Until arow = rngCol(1) End Sub

احذف هذا السطر من الكود واغلق الملف مع الحفظ وافتحه مره اخرى Dim FORMAT

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

السلام عليكم هذا المرفق على عجله ولاكن اريد منك الاطلا ع عليه هل هكذا الطلب ماتم اضافتة هو التالي ===================================== عند اضافة صنف جديد موجود في شيت المخزن يقوم بترحيل الكمية فوق الكمية التي في المخزن للصنف (حقل الباقي في المخزون) ===================================== وفي حالة عدم وجود الصنف في المخزن يقوم بإضافة الصنف في كلا من DATA_FLDO و المخزن ===================================== وتم اضافة مرجع للصنف وهو مايعتمد في التحقق من وجوده في شيت المخزن (ربما تكون صعبة عليك ترقيم الاصناف ولاكن صعبة التحقق من صنف اذا كان يحوي ارقام ونصوص ) ===================================== وبالنسبة لشيت المخزن ارجو ترتيب الاعمدة عملياً بمعنى يكون نفس اعمدة شيت DATA_FLDO واي تقارير اضافية مثل سعر الجملة وغيره ضيفه في اخر عمود (اتيح لك الفرصه بترتيبة مايتانسب مع عملك ) واي ملاحظات او اضافات انا موجود (موجود منفطع ) السموحة منك على التأخير والسلام عليكم DATA_RFRE.rar

الاستاذ القدير احمد حمود ابو عبدالله جزاك الله خير تعلمت منك الكثير ياكبير اخي الفاضل عبدالقادر احاول اعمل المطلوب اذا زبط ولا فالاساتذة موجودين لاني مشغول ماادخل النت الا يوم يومين في الاسبوع تحياتي

الاخ الاستاذ سعد عابد الحلاوة بوجودك ياعسل يسلملي هالطله الاخ الفاضل avogadrow هو اكيد بيصير بهذا الصغر لانه بيحتوي 13 عمود ولاكن اذا اردت اعمدة معينة للتقرير بقدر ازبطه لك بمعن ايه الاعمدة المطلوبة بالتقرير وانا موجود

الاخ الفاضل الجزيرة تسلم على مرورك العطر

السلام عليكم الاستاذ الحبيب احمد زمان اشكرك جدا على هذا التشجيع الاخ الفاضل وهذا كود اخر اضنه اضمن مع الطباعه Sub so() Application.ScreenUpdating = False On Error Resume Next Range("a1:m1").AutoFilter Sheets("sheet1").Range("$A$1:$M$2000").AutoFilter Field:=2, Criteria1:=RGB(255, _ 199, 206), Operator:=xlFilterCellColor Cells.Find(What:="Name", After:=[a1], SearchDirection:=xlPrevious).Select row_1 = ActiveCell.Row + 1 Range("a2" & row_1 & ":m" & row_1).Copy Sheets("Sheet2").Range("a3").PasteSpecial Paste:=xlPasteAll Sheets("Sheet1").Range("a1:m1").AutoFilter Field:=2 Application.CutCopyMode = False Application.ScreenUpdating = True Sheets("Sheet2").Select ER = WorksheetFunction.CountA(Range("a:m")) + 1 RN = "A2:m" & ER Sheets("Sheet2").Range(RN).PrintOut Copies:=1, Preview:=True, Collate:=True Application.ScreenUpdating = False Range("a3:m" & Rows.Count).Clear [a4].Select Application.ScreenUpdating = True Application.Calculation = xlCalc End Sub تحياتي Book2.alidroos.rar

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

ياللروعة ماشاء الله كود جميل جدا ولاكن انا اعشق 2007 سلمت وجزاك الله خير استاذ عماد

السلام عليكم اولا دوس CTR + F2 ثانياً Page setup ثالثاً Scaling بتشوف نقطة Fit to : ذي نقطة Fit to : انقر عليها مرتين لاحظ النتيجة تحياتي

السلام عليكم بعد اذنك استاذي القدير احمد زمان الاخ الفاضل هل هذا ماتريده انقر على زر تقرير للون المحدد ولاحظ على sheet2 تفضل المرفق Book2.rar

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