سليم حاصبيا

صدثقث العزيز المشكلة عندك انك تستغمل امر Select وهو امر لا يمكن ان ينفذ في اي شيت غير الشيت النشطة (اي الشيت التي تراها امامك على الشاشة)فكيف اذا كانت الشيت التي تريدها مخفية مثلاً مما يزيد الطين بلّة الكود الصحيح (بدون Select ) يغمل حتى ولو كانت الشيت المعنية بالأمر محفية Sub Macro3() Sheets("Sheet2").Range("C4:D8").ClearContents End Sub '++++++++++++++++++++++++ Sub Macro4() Sheets("Sheet2"). _ Range("Table1[[الإسم واللقب]:[تاريخ الميلاد]]").ClearContents End Sub

1- في هذا القسم من الكود تم استعمال حاصية الـــ Dictionery التي لا تسمح لتكرار البيانات داخلها الـــ Dictionery يضيف الى بياناته نوعين من العناصر Key و Items الـــ Key لا يمكن ان يتكرر 2- انا أقول للـ Dictionery في هذا القسم اذا كانت الحلية ( Cells(X, 1 غيرموجودة عتدك خذها لتمثل دور الـــ Key والخلية التي الى جانبها ( Cells(X, 2) تمثل الـــ__ ( Item) و اذا كانت موجودة Key اجمع الى ما يتبعها ( Cells(X, 2) ليمثل المجموع دور Items (في هذه الحالة وجدنا Items جديدة لهذا الــ Key الذي هو ( Cells(X, 1 على كل حال يمكن استبدال هذه الجزئية من الكود بهذه For X = 3 To a - 2 Dic(Cells(X, 1).Value) = _ Dic(Cells(X, 1).Value) + _ IIf(IsNumeric(Cells(X, 2).Value), Cells(X, 2).Value, 0) Next

و هذا ملف يمكنك منه خلاله الاختيار دمج الخلايا او عدم دمجها زر لكل اختيار (على 3 أعمدة (يمكن الاضافة قدر ما تريد) Option Explicit Sub Unmerg_cells() Application.ScreenUpdating = False If ActiveSheet.Name <> "Test" Then GoTo End_Me Dim lr#, i# Dim My_rg As Range, x, y, z, n Dim My_min lr = Cells(Rows.Count, "A").End(3).Row For i = 2 To lr If Cells(i, 1).MergeCells Then x = Cells(i, 1) y = Cells(i, 2) z = Cells(i, 3) n = Cells(i, 1).MergeArea.Rows.Count Cells(i, 1).UnMerge Cells(i, 1).Resize(n) = x Cells(i, 2).UnMerge Cells(i, 2).Resize(n) = y Cells(i, 3).UnMerge Cells(i, 3).Resize(n) = z i = i + n - 1 End If Next End_Me: Range("A1").Select Application.ScreenUpdating = True End Sub '++++++++++++++++++ Sub merge_all() Application.ScreenUpdating = False If ActiveSheet.Name <> "Test" Then GoTo End_Me Dim k% For k = 1 To 3 Call One_for_all(k) Next With Range("A1").CurrentRegion .Font.Size = 14 .Font.Bold = True End With End_Me: Range("A1").Select Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++++++ Sub One_for_all(ByVal Col As Integer) Application.DisplayAlerts = False Dim i%, lr%, My_rg As Range Dim x lr = Cells(Rows.Count, Col).End(3).Row Set My_rg = Cells(1, Col) For i = 1 To lr x = Cells(i, Col).Value If My_rg.Cells(1).Value = x Then Set My_rg = Union(My_rg, Cells(i, Col)) My_rg.MergeCells = True Else Set My_rg = Cells(i, Col) End If Next Application.DisplayAlerts = True End Sub الملف مرفق Merge_Unmerge_rows_Multiple_colmns.xlsm

الماكرو يتعاطى مع الخلايا المدمجة في اول ثلاثة اعمدة فقط الخلابا العادية ليس لها شأن

جرب هذا الكود Option Explicit Sub Unmerg_cells() If ActiveSheet.Name <> "ورقة1" Then Exit Sub Dim lr#, i# Dim My_rg As Range, x, y, z, n Dim My_min lr = Cells(Rows.Count, "D").End(3).Row For i = 2 To lr If Cells(i, 2).MergeCells Then x = Cells(i, 1) y = Cells(i, 2) z = Cells(i, 3) n = Cells(i, 2).MergeArea.Rows.Count Cells(i, 1).UnMerge Cells(i, 1).Resize(n) = x Cells(i, 2).UnMerge Cells(i, 2).Resize(n) = y Cells(i, 3).UnMerge Cells(i, 3).Resize(n) = z My_min = Application.Min(Range("d" & i).Resize(n)) Range("d" & i).Resize(n) = Format(My_min, "d/m/yyy") i = i + n - 1 End If Next End Sub الملف مرفق Gorh.xlsm

لا يمكن العمل على الصورة ارفاق الملف نفسه (او نموذج بسيط عنه اذا كان كبيراً)يمكن وضع اسماء مسنعارة A/B/C/...

هذا ملف اخر اذا كنت تريد الكسور Tafkeet_Daraga_with_fraction.xlsm

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

جرب هذا الكود Option Explicit Sub Get_aLL() Dim Rg_A As Range Dim Rg_D As Range, Rg_G As Range Dim a%, d%, g%, X% Dim St1$, St2$ Dim Dic As Object Range("k3").CurrentRegion.ClearContents Set Rg_A = Range("A3", Range("A2").End(4)) Set Rg_D = Range("D3", Range("D2").End(4)) Set Rg_G = Range("G3", Range("G2").End(4)) a = Rg_A.Rows.Count: d = Rg_D.Rows.Count g = Rg_A.Rows.Count St1 = "All Products": St2 = "All Volume" Set Dic = CreateObject("Scripting.dictionary") For X = 3 To a - 2 If Not Dic.exists(Cells(X, 1).Value) Then Dic(Cells(X, 1).Value) = Cells(X, 2) Else Dic(Cells(X, 1).Value) = Dic(Cells(X, 1).Value) + Cells(X, 2) End If Next '+++++++++++++++++++++++++ For X = 3 To d - 2 If Not Dic.exists(Cells(X, 1).Value) Then Dic(Cells(X, 4).Value) = Cells(X, 5) Else Dic(Cells(X, 4).Value) = Dic(Cells(X, 4).Value) + Cells(X, 5) End If Next '+++++++++++++++++++++++++ For X = 3 To g - 2 If Not Dic.exists(Cells(X, 7).Value) Then Dic(Cells(X, 7).Value) = Cells(X, 8) Else Dic(Cells(X, 7).Value) = Dic(Cells(X, 7).Value) + Cells(X, 8) End If Next '++++++++++++++++++++ Range("k3").Resize(Dic.Count) = _ Application.Transpose(Dic.keys) Range("L3").Resize(Dic.Count) = _ Application.Transpose(Dic.Items) Range("k2") = St1: Range("l2") = St2 Range("k2").CurrentRegion.Sort Key1:=Range("L2") _ , order1:=2, Header:=1 End Sub الملف مرفق Master.xlsm

ربما يكون المطلوب Option Explicit Dim E, W, N, S 'FROM CELL Z1 TO AC11 Dim t%, L%, letr Dim Co1(), a%, B_E As Boolean Dim Co2(), b%, B_W As Boolean Dim Co3(), c%, B_N As Boolean Dim Co4(), d%, B_S As Boolean '+++++++++++++++++++++ Sub quelque_chose() If ActiveSheet.Name <> "Salim" Then Exit Sub E = Array(193, 194, 195, 197, 199, 200, 201, _ 202, 203, 204, 205, 206, 236) W = Array(207, 208, 209, 210, 211, 212, 213) N = Array(214, 216, 217, 218, 219, 221, 222) S = Array(192, 196, 198, 223, 225, 227, 228, _ 229, 230, 237) End Sub '+++++++++++++++++++++ Sub My_test() quelque_chose Range("E2:H100").ClearContents L = Len(Cells(2, "C")) a = 1: b = 1: c = 1: d = 1 For t = 1 To L letr = Mid(Cells(2, "C"), t, 1) If letr = " " Then GoTo next_t If Asc(letr) >= 65 And _ Asc(letr) <= 122 Then GoTo next_t B_E = Not IsError(Application.Match(Asc(letr), E, 0)) B_W = Not IsError(Application.Match(Asc(letr), W, 0)) B_N = Not IsError(Application.Match(Asc(letr), N, 0)) B_S = Not IsError(Application.Match(Asc(letr), S, 0)) Select Case True Case B_E ReDim Preserve Co1(1 To a) Co1(a) = letr a = a + 1 Case B_W ReDim Preserve Co2(1 To b) Co2(b) = letr b = b + 1 Case B_N ReDim Preserve Co3(1 To c) Co3(c) = letr c = c + 1 Case B_S ReDim Preserve Co4(1 To d) Co4(d) = letr d = d + 1 Case Else GoTo next_t End Select next_t: Next If a > 1 Then Range("E2").Resize(UBound(Co1)) = _ Application.Transpose(Co1) End If If b > 1 Then Range("F2").Resize(UBound(Co2)) = _ Application.Transpose(Co2) End If If c > 1 Then Range("G2").Resize(UBound(Co3)) = _ Application.Transpose(Co3) End If If d > 1 Then Range("H2").Resize(UBound(Co4)) = _ Application.Transpose(Co4) End If End Sub الملف للمعاينة مرفق Arabic_Alphabet.xlsm

في اعتقادنا ان حروف اللغة العربية 28 حرفاً لكن الاكسل لا يعرفها هكذا لأن عنده (أ , إ , ا ,آ ) كلها مختلفة ونفس الشيء بالنسبة لــ (ت , ة , و , ؤ ) الخ...... لمعرفة كل الأخرف العربية غند الاكسل هذا الماكرو Option Explicit Sub test_me() Dim i%, arr() Dim k, Non_Arabic() Dim m% Non_Arabic = Array(215, 220, 224, 226, 231, 232, 233, 234, 235) m = 1 For k = 1 To 46 If IsError(Application.Match(k - 1 + 192, Non_Arabic, 0)) Then ReDim Preserve arr(1 To m) arr(m) = Chr(k - 1 + 192) m = m + 1 End If Next m = 2: k = 2 For i = 1 To UBound(arr) Cells(m, k) = arr(i) m = m + 1 If m = 9 Then m = 2: k = k + 1 Next End Sub الملف مرفق Araabic_alpha.xlsm

يمكن ان يكون هذا المطلوب date without_sam days.xlsm

استبدل اسم الصفحة الى Salim ( لحسن نسح الكود ولصقه بدون مشاكل اللغة العربية) ثم نفذ هذا الكود Option Explicit Dim sh As Worksheet Dim Rg As Range, cel As Range Dim my_formula '+++++++++++++++++++++++ Sub hid_Rows() Application.ScreenUpdating = False show_all For Each cel In Rg.Columns(2).Cells my_formula = _ Application.CountA(cel.Resize(, 4)) If my_formula = 0 Then cel.EntireRow.Hidden = True End If Next Application.ScreenUpdating = True End Sub '++++++++++++++++++++++++++++ Sub show_all() Set sh = Sheets("Salim") Set Rg = sh.Range("B4").CurrentRegion Rg.EntireRow.Hidden = False End Sub الملف مرفق Yesk.xlsm

جرب هذا الملف في حال تريد كل الطلاب من نفس الصف (ذكر + أنثى) اترك الخلية H2 فارغة واضغط الزر Run Moujahed 2013.xlsm

اذا كان النض يحتوي على اكثر من عدد (قي أوله أو منتصفه أو آخره) وجدت لكم الحل بواسطة هذا الكود Option Explicit Sub Extract_Number_From_Text() Dim rgx As Object Dim My_Number As Object Dim ws As Worksheet Dim i%, m%, k%, x%, Ro% Set rgx = CreateObject("VBScript.RegExp") Set ws = Worksheets("Salim") Ro = ws.Cells(Rows.Count, 1).End(3).Row m = 1: k = 3 With ws.Cells(m, k).CurrentRegion .ClearContents .Interior.ColorIndex = xlNone End With With rgx .Global = True: .Pattern = "(\d+\.?\d+)" For i = 1 To Ro If .Test(ws.Cells(i, 1)) Then Set My_Number = .Execute(ws.Cells(i, 1)) For x = 0 To My_Number.Count - 1 ws.Cells(m, k).Offset(, x) = Val(My_Number.Item(x)) Next x End If m = m + 1 Next i End With With ws.Cells(m, k).Resize(, 2) .Formula = "=SUM(C1:C" & m - 1 & ")" .Value = .Value .Interior.ColorIndex = 6 End With ws.Cells(m, k).Offset(, 2) = "Sum" Set rgx = Nothing: Set ws = Nothing Set My_Number = Nothing End Sub الصفحة salim من هذا الملف Hasan_Mhd_With_Macro.xlsm

ممكن هذا ما تعنيه قي الخلية F2 هذه المعادلة واسحب نزولاً =IF(A2="","",CHAR(INT((ROWS($A$1:A1)-1)/6)+65)) الملف مرفق seddiki_New.xls

تم التعديل على الملف 1-يمنع ادخال بينات مكررة 2- لتعديل اي بيانات ادخل الاسم في خانة الاسم ادخل باقي البيانات التي تريد تعديلها اضغط الزر UPDATE يمكنك الاستعانة بهذه الصور الملف النهائي مرفق Example_Final.xlsm

يجب طرح المواضيع دفعة واحدة اذا قمت بتلبية هذا الامر من يضمن انك لا تريد شيئا اخر (مثلاً عدم القبول بالتكرار)

لا أعلم اذا كان هذا المطلوب seddiki_adz.xls

لا ضرورة لذلك بمكنك التعديل راساً في الشيت

تم التعديل كما تريد الصف الأول من B الى E والعامود الأول A محمي ضد المسح والكتابة (لعدم التغيير عن طربق الخطأ) استعمل اليوزر كما في الصورة الملف بعد التعديل مرفق Example_1.xlsm

بعد اذن اخي الرائد معادلة ثانية في الصورة المرفقة الملف مرفق ايضاً Hasan_Mhd.xlsx

صديقي العزيز لا تستطيع مسح اي خلية أو عدة خلايا(بل يجب مسح صف او عدة صفوف بالكامل او عامود او عدة أعمدة بالكامل)

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

بعد اذن احي أحمد بدره هذا الكود ربما يكون اسهل قليلاً (الشيت 3) Option Explicit Sub Get_data() Dim S As Worksheet Dim T As Worksheet Dim cret_rg As Range Dim col% Dim s_rg As Range Set S = Sheets("Sheet2"): Set T = Sheets("Sheet3") Set s_rg = S.Range("A1").CurrentRegion If T.Range("B3").CurrentRegion.Rows.Count > 1 Then T.Range("B3").CurrentRegion.Offset(1). _ Resize(T.Range("B3").CurrentRegion.Rows.Count - 1).Clear End If If s_rg.Rows(1).Find(T.Range("H1"), lookat:=1) Is Nothing Then Exit Sub col = s_rg.Rows(1).Find(T.Range("H1"), lookat:=1).Column With T .Range("B3") = S.Range("A1") .Range("C3") = S.Range("B1") .Range("D3") = T.Range("H1") .Range("H2") = "غ" Set cret_rg = .Range("H1:H2") s_rg.AdvancedFilter 2, cret_rg, .Range("B3:D3") .Range("H2") = "" End With End Sub الملف مرفق Class_3.xlsm