سليم حاصبيا

تم معالجة الامر ملاحظة:عدد النطاقات المنسوخة لا يتساوى مع عدد النطاقات المنسوخ اليها لذلك انا وضعت العدد Z الذي يساوي الحد الادنى من عدد النطاقات المنسوخة والمنسوخ اليها يرجى تحديد النطاقات بدقة اكثر من خلال الكود report2salim.rar

جرب الان الموردن salim 1.rar

جرب هذا الكود Sub verifacation() x = FormulaArray = "=AND($A$1:$A$100=1)" MsgBox x End Sub

في عملية الفلترة لا بد من تحديد جدول لتقوم الفلترة على اساسه انا اخذت الخلية A4 , يمكنك انت ان تختار ما تشاء شرط ان تكون الخلية داخل الجدول sh.range("a4").AutoFilter لا يعمل اكود بدون اي خلية مثلاً هكذا sh.AutoFilter جرب هذا اذا كان الجدول يضم الاعمدة من A الى F sh.range("a4:f4").AutoFilter

تم التعديل Parties 1.rar

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

جرب هذا الملف الطلاب salim.rar

جرب هذا الملف Parties.rar

المعادلة الصحيحة =IF($D$3=0,"",(TRIM(RIGHT(INDEX($C$2:$C$13,$D$3),11))*1)-(TRIM(MID(INDEX($C$2:$C$13,$D$3),FIND(":",INDEX($C$2:$C$13,$D$3))+1,11))*1)+1)

ربما يكون المطلوب ضم خلايا وزيادة اصفار salim.rar

اليك الكود اللازم لهذا الشيء Sub My_rg() Set my_rg1 = Range("L8:L12,M28:M35,L13:N13,l17,l19,l21,l23,l26,l30:l31,l33:l37,m37,l46,l38") Set my_rg2 = Range("e8,h28,c13,e17,c19,c21,c23,e31,c33,g37") x = my_rg1.Areas.Count y = my_rg2.Areas.Count Z = Application.Min(x, y) For i = 1 To Z my_rg1.Areas(i).Copy my_rg2.Areas(i) Next End Sub

جرب هذا الملف Add_sheets.rar

جرب هذا الملف الذي يمكنك العمل عليه بعد التعديل My_table.rar

ما الشرط لكتابة s وما الشرط لكتابة ف

الكود المطلوب Private Sub Workbook_BeforeClose(Cancel As Boolean) For Each sh In ThisWorkbook.Worksheets If sh.AutoFilterMode = False Then sh.range("a4").AutoFilter Else sh.ShowAllData End If Next End Sub

هذا ما انا فهمته من سؤالك Exemple.rar

تفضل المطلوب الموردن salim1.rar

تم التعديل على الكود Sub Crazy_Translate() Dim ws1, ws2, ws3 As Worksheet Dim lr1, lr2, m, n As Integer Application.ScreenUpdating = False Set ws1 = Sheets("sheet1"): Set ws2 = Sheets("sheet2"): Set ws3 = Sheets("sheet3") ws3.Cells.Clear lr1 = ws1.Cells(Rows.Count, "j").End(3).Row lr2 = ws2.Cells(Rows.Count, "f").End(3).Row For i = 1 To lr1 ws1.Range("j" & i).Copy ws3.Cells(m + 1, 1).PasteSpecial Paste:=xlPasteValues ws3.Cells(m + 1, 1).PasteSpecial Paste:=xlPasteFormats: m = m + 2 Next For k = 1 To lr2 ws2.Range("f" & k).Copy ws3.Cells(n + 2, 1).PasteSpecial Paste:=xlPasteValues ws3.Cells(n + 2, 1).PasteSpecial Paste:=xlPasteFormats: n = n + 2 Next ws3.Columns.AutoFit Application.ScreenUpdating = True End Sub

Sub Crazy_Translate() Dim ws1, ws2, ws3 As Worksheet Dim lr1, lr2, m, n As Integer Application.ScreenUpdating = False Set ws1 = Sheets("sheet1"): Set ws2 = Sheets("sheet2"): Set ws3 = Sheets("sheet3") ws3.Cells.ClearContents lr1 = ws1.Cells(Rows.Count, 1).End(3).Row lr2 = ws2.Cells(Rows.Count, 1).End(3).Row For i = 1 To lr1 ws1.Range("a" & i).Resize(1, 10).Copy ws3.Cells(m + 1, 1).PasteSpecial Paste:=xlPasteAll: m = m + 2 ws2.Range("a" & i).Resize(1, 10).Copy ws3.Cells(n + 2, 1).PasteSpecial Paste:=xlPasteAll: n = n + 2 Next ws3.Columns.AutoFit Application.ScreenUpdating = True End Sub جرب هذا الكود

ربما كان المطلوب مثال salim.rar

اليك ما يجب عمله 1-قم بتسمية كل النطاقات التي تريد نسخها بأي اسم فليكن myrange1 2 - قم بتسمية كل النطاقات التي تريد النسخ اليها بأي اسم فليكن myrange2 3-نفذ هذا الكود Sub Salim_copy() For i = 1 To Range("myrange1").Areas.Count Range("myrange1").Areas(i).Copy Range("myrange2").Areas(i).Cells(1, 1) Next End Sub

جرب هذا الكود يجب كتابة اسم الصفحة اذا كان تاريخاً بشكل 2016-11-17 لان اكسل يرفض اسم اي صفحة يحتوي على / يجب كتابة رقم الصفحة بشكل 1,2,3,20 ,25 و هكذا Sub taruba() On Error Resume Next 'Write i as number between 1 and 31 i = Application.InputBox("Get_me the sheet's name", "Excel Tell You", 1) If IsEmpty(Len(Sheets(i & "-11-2016").Name)) Then MsgBox "this sheets not exits": Exit Sub Sheets(i & "-11-2016").Select '=================================== ' Write here your code '================================ End Sub

جرب هذا لملف حاول ان تغير قيمة A1 Or B1 Msg_Box.rar

بدل الى هذا الكود Private Sub Worksheet_Deactivate() On Error Resume Next Application.ScreenUpdating = False my_sheet = ActiveSheet.Name Application.Undo With ActiveSheet If .AutoFilterMode = True Then .ShowAllData End With Sheets(my_sheet).Select Application.ScreenUpdating = True End Sub

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