سليم حاصبيا

التخفيف من حجم الملف (2.6 ميغا) انظر كبف اصبح (70كيلو) =====>>>>> (2600 ÷ 70) 36 مرة أقل و ذلك بعد ازالة النتسيقات و رركشة الألوان nany.xlsm

الماكرو الجدبد ينفذه الزر الثاني (اللون الأحمر) (CommandButton4) و ليس الزر الاول

الكود لا بلعي سيئاً

Try This File Ah_saed.xlsx

تفضل يا صديقي Hisham.xlsx

للتغامل مع جداول اكسل و للحصول على نتائج دقيقة 1- لا يجب ان يحتوي اي جدول على صفوف فارغة ولا على خلايا مدمجة 2-ضرورة فصل كل جدول غن الاحر بصف فارغ او عامود فارغ

وضعت لك كود للزر الأول يمكنك اقتباسه لياقي الازرار Option Explicit Sub Masrouf() 'CommandButton4 Dim D As Worksheet Dim P As Worksheet Dim How_many%, I%, x% Dim Arr_sh(), arr_From() Arr_sh() = Array("يومية1", "يومية2", "يومية3") arr_From = Array("M6", "P6") Set D = Sheets("إدخال البيانات") ' For I = LBound(arr_From) To UBound(arr_From) ' D.Range(arr_From(I)) = Chr(Application.RandBetween(65, 90)) ' Next For I = LBound(arr_From) To UBound(arr_From) If D.Range(arr_From(I)) = vbNullString Then MsgBox "بيانات غير مكتملة: ", 64 Exit Sub End If Next For I = 0 To 2 If Application.CountA(Sheets(Arr_sh(I)).Range("K8:K17")) < 10 Then Set P = Sheets(Arr_sh(I)) Exit For End If Next If P Is Nothing Then Exit Sub How_many = Application.CountA(P.Range("K8:K17")) + 8 With P.Cells(How_many, "K") For I = LBound(arr_From) To UBound(arr_From) .Offset(, I) = D.Range(arr_From(I)) Next End With x = Application.CountA(P.Range("K8:K17")) P.Range("J8").Resize(x).Value = _ Evaluate("Row(1:" & x & ")") For I = LBound(arr_From) To UBound(arr_From) D.Range(arr_From(I)) = vbNullString Next End Sub Osama_More_but.xlsm

حذف البيانات فقط وليس حذف الصف الكود يفعل هذا الشيء (يمكنك التأكد بكناية اي شيء /خارج الجدول/ في صف تريد حذف بياناته )

جرب هذا الملف الصفحة Sheet1 Abdallah.xlsx

يمكن ان يكون المطلوب Sameh.xlsx

الكود المطلوب Option Explicit Sub del_rows() Dim My_sh As Worksheet Dim Tabl As Range Dim Rg_Del As Range Dim MotB, Motc, i% Set My_sh = Sheets("Data") MotB = My_sh.Range("B2") Motc = My_sh.Range("C2") Set Tabl = My_sh.Range("G3", Range("K2").End(4)) If Tabl.Rows.Count > 10000 Then Exit Sub For i = 1 To Tabl.Rows.Count If Tabl.Cells(i, 1) = MotB _ And Tabl.Cells(i, 2) = Motc Then If Rg_Del Is Nothing Then Set Rg_Del = Tabl.Cells(i, 1).Resize(, 5) Else Set Rg_Del = _ Union(Rg_Del, Tabl.Cells(i, 1).Resize(, 5)) End If End If Next i If Not Rg_Del Is Nothing Then Rg_Del.Delete End If End Sub Fouri.xlsm

جرب هذا الكود Private Sub CommandButton1_Click() Dim D As Worksheet Dim P As Worksheet Dim How_many%, I%, x% Dim Arr_sh(), arr_From() Arr_sh() = Array("PAGE1", "PAGE2", "PAGE3") arr_From = Array("E3", "D5", "D7", "D9", "D11", _ "G5", "G7", "G9") Set D = Sheets("Data") For I = LBound(arr_From) To UBound(arr_From) If D.Range(arr_From(I)) = vbNullString Then MsgBox "Imcopmlete Data In: " & Chr(10) & _ D.Range(arr_From(I)).Address & Chr(10) & _ "I Cannot contenue", 64 Exit Sub End If Next For I = 0 To 2 If Application.CountA(Sheets(Arr_sh(I)).Range("b8:b37")) < 30 Then Set P = Sheets(Arr_sh(I)) Exit For End If Next If P Is Nothing Then Exit Sub How_many = Application.CountA(P.Range("b8:b37")) + 8 With P.Cells(How_many, "B") For I = LBound(arr_From) To UBound(arr_From) .Offset(, I) = D.Range(arr_From(I)) Next End With x = Application.CountA(P.Range("b8:b37")) P.Range("A8").Resize(x).Value = _ Evaluate("Row(1:" & x & ")") For I = LBound(arr_From) To UBound(arr_From) D.Range(arr_From(I)) = vbNullString Next End Sub osama elmorsy.xlsm

الكود المطلوب Private Sub CommandButton2_Click() 'Ta3dil Dim lr%, i% Dim bol As Boolean Dim Asnaf As Worksheet Dim F_rg As Range, Where As Range Dim Ro%, mot Set Asnaf = Sheets("الاصناف") lrow = Asnaf.Range("C" & Rows.Count).End(xlUp).Row If TextBox1.Value = "" Then MsgBox ("لا يوجد بيانات للتعديل") Exit Sub End If mot = TextBox1.Text Set Where = Asnaf.Range("C3:C" & lrow) Set F_rg = Where.Find(mot, lookat:=1) If F_rg Is Nothing Then MsgBox "I cannot Find: " & Chr(34) & mot & Chr(34) & _ Chr(10) & "In the column(C)" Exit Sub End If Ro = F_rg.Row With Asnaf.Range("C" & Ro) For i = 1 To 8 If i = 6 Then i = 7 .Offset(, i - 1) = Me.Controls("TextBox" & i) Next .Offset(, 5) = Me.ComboBox6.Value End With End Sub Atfan_1.xlsm

أولاً اختصار لكود الاضافة Private Sub CommandButton1_Click() Dim LR As Integer Dim i%, bol As Boolean lrow = Sheet2.Range("C" & Rows.Count).End(xlUp).Row LR = WorksheetFunction.CountIf(Sheet2.Range("C4:C" & lrow), TextBox1.Value) If LR >= 1 Then MsgBox "كود الصنف موجود مسبقا" Exit Sub End If For i = 1 To 8 If i = 6 Then i = 7 If Me.Controls("TextBox" & i) = vbNullString Then bol = True MsgBox "You Have Empty textbox" & Chr(10) & _ "I cannot continue" Exit Sub End If Next i If Me.ComboBox6 = vbNullString Then bol = True MsgBox "You Have Empty Combobox" & Chr(10) & _ "I cannot continue" Exit Sub End If If Not bol Then With Sheet2.Range("C" & lrow + 1) For i = 1 To 8 If i = 6 Then i = 7 .Offset(, i - 1) = Me.Controls("TextBox" & i) Me.Controls("TextBox" & i) = vbNullString Next .Offset(, 5) = Me.ComboBox6.Value Me.ComboBox6 = vbNullString End With End If CheckBox1.Value = False MsgBox ("تمت الاضافة") End Sub Atfan.xlsm

انت تكتب الوقت بشكل خاطىء (الصورة) يجب كتابته كما في الخلية D3 من هذا الملف Wask.xlsx

جرب هذا الملف Option Explicit Sub Filter_me() Dim Ar(), i%, k% Dim My_rg As Range Dim cret, itm Dim Rs As Worksheet Set Rs = Sheets("رئيسي") i = -1 With Application .ScreenUpdating = False End With Set My_rg = Rs.Range("A1").CurrentRegion If Rs.AutoFilterMode Then My_rg.AutoFilter End If For k = 1 To Sheets.Count If Sheets(k).Name <> Rs.Name Then i = i + 1 ReDim Preserve Ar(i) Ar(i) = Sheets(k).Name End If Next For Each itm In Ar cret = Sheets(itm).Name Sheets(itm).Range("A1").CurrentRegion.Clear My_rg.AutoFilter Field:=10, Criteria1:=cret My_rg.AutoFilter Field:=9, Criteria1:="<>0", _ Operator:=xlAnd My_rg.SpecialCells(2, 23).Copy Sheets(itm).Range("a1").PasteSpecial (8) Sheets(itm).Range("a1").PasteSpecial Next If Rs.AutoFilterMode Then My_rg.AutoFilter End If Rs.Select With Application .ScreenUpdating = True .CutCopyMode = False End With End Sub الملف مرفق Mrgane.xlsm

أنت طلبت عند اختيار اول مره لذلك يتفذ الماكرة و اذا كانت الخلية C10 فارغة قم بتفريغ الحلية C10 ونفذ الماكرو

الماكرو المطلوب (كم هو اسهل العمل بدون خلايا مدمجة) Dim RG As Range Const P As String = "Positive" Const N As String = "Negative" Dim Mot '+++++++++++++++++++++++++++++++++++++++++ Private Sub Worksheet_Change(ByVal Target As Range) Set RG = Range("E9:E16") Application.EnableEvents = False If Not Intersect(Target, RG) Is Nothing _ And Target.Cells.Count = 1 Then Select Case True Case Target.Value Like "#*" Mot = N Case Else Mot = P End Select If Range("C10") = "" Then Range("C10") = Mot If Mot = P Then Range("F12").Select End If End If Application.EnableEvents = True End Sub File_tiba.xlsm

طبعاً

وضعت عهداً على نفسي ان لا أعمل مع اي ملف يحتوي فى خلايا مدمجة في جدول حيث يعمل اي كود ما الغاية مثلاً من دمج 5 أعمدة (O,P,Q,R,S) فقط من اجل كتابة (+++) تفضل يازالة الحلايا المدمجة (مع الشرح اللازم لما تريد)

تم معالجة الامر على 3 خلايا (اختصار الملف من اكثر من 1000 صف الى حوالي 50) لمعاينة المعادلات يمكنك تكملة الموضوع Ahmad.xlsx

جرب هذا الملف my_user.xlsm

حاول تخفيف حجم الملف (3.5 ميغا) لأن البرنامج بتوقف عند فنح الملف

المشكلة كانت في عدم ترتيب الصفوف حسب الــ Grade تم معالجة الأمر بتعديل الكود بحيث يعمل في كل الاحتمالات (ترتيب او عدم الترتيب) Sub First_Third_New() Dim sh As Worksheet Dim sh1 As Worksheet Dim My_rg As Range Dim F_rg As Range, xx As Long Dim ro As Long, i As Long, a% Dim k As Byte, m As Byte Dim Cret1, Cret2 Dim Col As Object, Dic As Object Dim Lt, t%, Ar_count, y, kk% Dim Mn, A_arr() Application.ScreenUpdating = False Set sh = Sheets("Salim") Set sh1 = Sheets("Sheet1") Set My_rg = sh.Range("A1").CurrentRegion Set Col = CreateObject("System.Collections.ArrayList") Set Dic = CreateObject("Scripting.Dictionary") sh1.Range("C8:M13").ClearContents ro = My_rg.Rows.Count sh.Cells(2, 1).Resize(ro - 1, 12).Interior.ColorIndex = xlNone If sh1.Range("V8") = "" Then sh1.Range("V8") = "Grade 1" If sh1.Range("V7") = "" Then sh1.Range("V7") = "Arabic Language" Cret1 = sh1.Range("V8"): Cret2 = sh1.Range("V7") If sh.FilterMode Then My_rg.AutoFilter End If My_rg.AutoFilter Field:=1, _ Criteria1:=Cret1 My_rg.AutoFilter Field:=3, _ Criteria1:=Cret2 Set My_rg = My_rg.Columns(13) _ .Resize(ro - 1).SpecialCells(12) Mn = Application.Large(My_rg, 5) Ar_count = My_rg.Areas.Count For y = 2 To Ar_count For kk = 1 To My_rg.Areas(y).Rows.Count ReDim Preserve A_arr(a) A_arr(a) = _ My_rg.Areas(y).Cells(kk) a = a + 1 Next kk Next y If a = 0 Then Exit Sub For i = LBound(A_arr) To UBound(A_arr) If IsNumeric(A_arr(i)) Then Col.Add Val(A_arr(i)) End If Next i Col.Sort Col.Reverse For t = 0 To Col.Count - 1 If Col(t) >= Mn Then Dic(Col(t)) = vbNullString End If Next m = 8: t = 0 Do Until t = Dic.Count + 1 Set F_rg = My_rg.Find(Dic.keys()(t) _ , lookat:=1) If Not F_rg Is Nothing Then xx = F_rg.Row: Lt = xx Do sh.Cells(Lt, 1).Resize(, 12).Interior.ColorIndex = 6 With sh1.Cells(m, "C") .Value = sh.Cells(Lt, "B") .Offset(, 1).Resize(, 9).Value = _ sh.Cells(Lt, "D").Resize(, 9).Value .Offset(, 10) = F_rg m = m + 1 End With Set F_rg = My_rg.FindNext(F_rg) Lt = F_rg.Row If Lt = xx Then Exit Do Loop End If t = t + 1 If t = Dic.Count Then Exit Do Loop If sh.FilterMode Then My_rg.AutoFilter End If Application.ScreenUpdating = True Set sh = Nothing Set My_rg = Nothing: Set F_rg = Nothing Set Col = Nothing: Set Dic = Nothing Erase A_arr End Sub Masry_Super.xlsm

كيف لنا التعامل مع صورة بمعرفة الخطأ الخطأ ربما كان هنا (اسم الصفحة)