سليم حاصبيا

اخي ياسر يجري هذا الامر لأني اخترت العمر والجنسية ونوع العمل بمعادلة عشوائية و كل شيء يصبح طبيعياً بعد تثبيت البيانات (لاحظ المعادلة في احد هذه الاعمدة من المرفق الاول) تم التعديل show_in top 2.zip

حدد فقط الصف الذي تريد اكسل يخفي لك كل شيء و لا ترى الا ما تريد بكبسة زر show_in top.zip

جرب هذا الشيء list_all_data.zip

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

يجب تعديل النطاق الى الذي تريده range("ar7:ar98") و كذلك ادراج الاسم الصحيح الزر Bitton 1 انظر الى المرفق (الملف الاول) , Sub Change_Color_Bot_Text() If Range("a1:a8").SpecialCells(2).EntireRow.Hidden = False Then ActiveSheet.Shapes.Range(Array("Button 1")).Select Selection.Characters.Text = "اخفاء" With Selection.Characters(Start:=1, Length:=5).Font .Name = "Traditional Arabic" .Size = 25 .Bold = True .ColorIndex = 3 End With '''''''''''''''''''''''''''''''''''''''''''''''' Else ActiveSheet.Shapes.Range(Array("Button 1")).Select Selection.Characters.Text = "إطهار" With Selection.Characters(Start:=1, Length:=5).Font .Name = "Traditional Arabic" .Size = 25 .Bold = True .ColorIndex = 5 End With ''''''''''''''''''''''''''''''''''''''''''''''''''' End If Range("a1:a8").SpecialCells(2).EntireRow.Hidden = Not (Range("a1:a8").SpecialCells(2).EntireRow.Hidden) End Sub change_color_button.zip every 3 cells in sheet salim advanced.zip

الملف معقد بعض الشيء اذ لا يسمح بالدخول ليه

اكتب هذا الكود و عين له زر على الصفحة انه يقوم بأخفاء الصفوف المطلوبة و بكبسة ثانية يعيدها الى الظهور Sub hid_text() Range("ar7:ar98").SpecialCells(2).EntireRow.Hidden = Not (Range("ar7:ar98").SpecialCells(2).EntireRow.Hidden) End Sub

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

استاذ اراهيم هو حاجة صعبة الدوس على اعجاب

اخي ياسر اليك المزيد حول هذا الموضوع every n cells in sheet salim ++.zip

انسخ هذا الكود وضعه في حدث Workbook Private Sub Workbook_Open() UserForm2.Show vbModeless End Sub

اخي ياسر مشكور جداً على هذا التعليق لاحطت ان هناك خطأ بسيط في الكود يتمثل في هذا اللسطر: المفروض انه في حالة تحطي عدد الصفوف ان تكون N=lr وليس N=1 يرجى الانتباه الى هذا الامر If N >= LR Then N = 1 every 3 cells in sheet salim advanced.zip

تفضل اخي الملف جاهز وتحت لطلب و لمزيد من الخيارات ----- الملف الثاني every 3 cells in sheet salim.zip every 3 cells in sheet salim advanced.zip

اكتبالكود للزر الذي يفتح اليوزرفورم بهذا الشكل Userform1 هو اسم اليوزر (يجب تغييره حسب اسم اليوزر فوم عندك) و Button1 هو اسم الزلر يمكن ان يكون مختلفاً عندك ايضاً Sub Button1_Click() UserForm1.Show vbModeless End Sub بالاختصار اضف هذه العباره على الكود الذي يفتح اليوزر vbModeless بعد ان تضع مسافة فارغة بعد كلمة Show

اخي محمد اعتقد انه يجب وضع شرط الا تكون الخلية المعنية في أول عامود (و اذ ا كانت كذلك شرط اخر) لأن في هذه الخالة A.Offset(0, -1) تعطينا خطأ

حاول استبدال الماكرو بهذا (لا توجد اخطاء) Sub copy_every_3() Application.ScreenUpdating = False y = 0 x = Sheets.Count Do While x > 1 Application.DisplayAlerts = False Sheets(x).Delete x = x - 1 Loop Application.DisplayAlerts = True lr = Sheets(1).Cells(Rows.Count, 1).End(3).Row For k = 0 To lr Step 3 Sheets(1).Range("a" & k + 1 & ":a" & k + 3).Copy Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = "list" & Chr(y + 65) ActiveSheet.Range("a1").PasteSpecial (xlValues) ActiveSheet.Columns(1).AutoFit ActiveSheet.Range("a1").Select y = y + 1 Next Sheets("ورقة1").Activate Range("a1").Select Application.CutCopyMode = False Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub

اذا كنت فهمت المقصود جرب هذا الكود Private Sub Workbook_Open() myaddress = Selection.Address Application.Goto Range(myaddress), True End Sub

المشكلة كما اطن ان عملية الحساب يمكن ان تكون يدوية اذهب الى Formula>>> calculation >>> autumatic ان شاء الله تحل المشكلة

اخي ياسر لقد حاولت حذفه كما اشرت لي و لكن لا فائدة مع العلم اني لم اقم برفع اي ملف في تلك المشاركة والله اعلم من اين جاء الملف المرفوع على كل حال هذا الملف الذي وضعته مع الكود كما يمكن الاطلاع على الملف لسابق لابداء الرأي حوله (اعتقد لا مانع من ذلك) every 3 cells in sheet.zip

جرب هذا الكود (المرفق المرفوع ليس له علاقة بالأمر ولم استطيع حذفه) ولا ادري حتى كيف تم رفعه مع انه لمشاركة ثانية على هذا العنوان http://www.officena.net/ib/topic/64192-معاينة-محددة/#comment-417279 سؤال بسيط للادارة : كيف يمكن التراجع عن رفع ملف تم ادراجه الخطا؟ و عملية الحذف لا تستجيب Sub copy_every_3() Application.ScreenUpdating = False y = 0 x = Sheets.Count t = x If t > 1 Then On Error Resume Next For i = 2 To t Application.DisplayAlerts = False Sheets(i).Delete Next Else End If lr = Sheets(1).Cells(Rows.Count, 1).End(3).Row For k = 0 To lr Step 3 Sheets(1).Range("a" & k + 1 & ":a" & k + 3).Copy Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = "list" & Chr(y + 65) ActiveSheet.Range("a1").PasteSpecial (xlValues) ActiveSheet.Columns(1).AutoFit y = y + 1 Next Sheets(1).Range("a1").Select Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub My_print_Set_Up.zip

جرب هذا لكود (انه يقوم بطباعة كل 25 سطر على صفحة واحدة مع العنوان الرئيسي) يمكنك تغيير العدد 25 من خلا ل الكود بتغيير مقدار العامل deg في السطر رقم 10 للمزيد انظر الى المرفق Sub my_setup() Application.ScreenUpdating = False k = 0 ActiveSheet.PageSetup.PrintArea = "" lr1 = Cells(Rows.Count, 1).End(3).Row On Error Resume Next ActiveSheet.PageSetup.PrintTitleRows = "$1:$1" Range("a1:a" & lr1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete deg = 25 'you can change this number lr = Cells(Rows.Count, 1).End(3).Row For i = 0 To lr Step deg If lr - i < deg Then Exit For ActiveWindow.View = xlPageBreakPreview Set ActiveSheet.HPageBreaks(k + 1).Location = Range("A" & i + deg + 2) k = k + 1 Next m = "$A$1:$E$" & lr1 & """" ActiveSheet.PageSetup.PrintArea = m ActiveSheet.DisplayPageBreaks = False ActiveWindow.View = xlNormalView Application.ScreenUpdating = True End Sub My_print_Set_Up.zip

جرب هذا الملف tafkit _notes.zip

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

جرب هذا الملف اذا اعجبك انسخ الكود اليه مع التعديلات الازمة Print Set_up.zip

جرب هذا الشيء Book1 salim.zip