سليم حاصبيا

الملف عندي يعمل بصورة طبيعية لا أعلم ربما كانت المشكلة عندك في البرنامج بالنسبة للمعادلة في الخلية A4 من الصفجة ورقة2 يفضل استعمال هذه المعادلة =CONCATENATE(A2:AA2,";")

ليست المرة الاولى التي اقول فيها انه يجب على الجدول في اكسل ان يكون معزولاُ عن اي بيانات اخرى (اعتزال كورونا) لذلك تم ادراج صف فارغ (الصف رقم 10) لعزل الجدول والحلقة التكرارية تبدأ من الصف رقم 12 الملف مرفق salim_Correction.xlsm

جرب هذا الماكرو Option Explicit Sub ALL_in_one_cells() Dim ro, st$, i% ro = Cells(Rows.Count, 1).End(3).Row For i = 1 To ro If Cells(i, 1) <> vbNullString Then st = st & Cells(i, 1) & "," End If Next st = Mid(st, 1, Len(st) - 1) & "." Cells(3, 4) = st Cells(3, 4).Columns.AutoFit End Sub الملف مرفق One_for_All.xlsm

انا وانت نعرف الكلمات التي لها معنى لكن الاكسل و كل كمبيوترات العالم لا تعرفها

كان من المفروض رفع الملف مسبقاً دون تضييع وقت الكود Option Explicit Sub give_data_by_50() If ActiveSheet.Name <> "data" Then Exit Sub Dim D As Worksheet, D2 As Worksheet Dim i%, x%, n%, Laste_Row%, Ro%, col%, m%, k%, last_col% Dim arr(), Tile() Set D = Sheets("data"): Set D2 = Sheets("data2") Laste_Row = D.Cells(Rows.Count, 1).End(3).Row D2.Cells.Clear x = (Laste_Row \ 50) + 1 k = 1 ReDim arr(1 To x) For m = 1 To x arr(m) = 50 * (k - 1) + 3 k = k + 1 Next Ro = 3: col = 1 For k = 1 To UBound(arr) D2.Cells(Ro, col).Resize(50).Value = _ D.Range("A" & arr(k)).Resize(50).Value D2.Cells(Ro, col + 1).Resize(50).Value = _ D.Range("B" & arr(k)).Resize(50).Value D2.Cells(Ro, col + 2).Resize(50).Value = _ D.Range("G" & arr(k)).Resize(, 50).Value D2.Cells(1, col + 3).ColumnWidth = 0.75 D2.Cells(4, col + 3).Formula = "=""""" col = col + 4 Next last_col = D2.Cells(4, Columns.Count).End(1).Column Tile = Array("رقم ", "الاسم و اللقب ", "القسم") For m = 1 To last_col Step 4 D2.Cells(2, m + 3).Resize(51). _ Interior.ColorIndex = 40 D2.Cells(2, m).Resize(, 3) = Tile Next With D2.Cells(2, 1).Resize(51, last_col - 1) .Borders.LineStyle = 1: .HorizontalAlignment = 1 .VerticalAlignment = 2: .Font.Size = 14 .Font.Bold = True: .InsertIndent 1 .Columns.AutoFit End With With D2.Cells(2, 1).Resize(, last_col - 1) .HorizontalAlignment = 3 .Interior.ColorIndex = 6 End With n = Application.CountA(D2.Cells(2, last_col - 2).Resize(50)) D2.Cells(n + 2, last_col - 3).Resize(50 - n + 1, 4).Clear Set D = Nothing: Set D2 = Nothing Erase arr: Erase Tile End Sub New_std_salim.xlsm

اضف هذا السطر الوحيد(بين علاملات الـــ +) في المكان المناسب لم استطع رفع الكود من جديد لضعف النت If m=7 then MsgBox "No Data to transfer": Exit Sub

الملف قد مسحته من جهازي ارفع الملف من جديد للمعاينة

جرب هذا الكود الكود فيما بعد نظراً لضعف النت الملف مرفق Salim_1411.xlsm

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

أولاً في هذه الحالة لست بحاحة الى arr_num ثانياً الكود الصحيح Option Explicit Sub give_data() If ActiveSheet.Name <> "data" Then Exit Sub Dim Laste_Row%, k%, m%, i% Dim arr Dim rg As Object Laste_Row = Sheets("data").Cells(Rows.Count, 1).End(3).Row Sheets("data2").Range("A3").Resize(3000, 3).ClearContents Set rg = CreateObject("system.collections.arraylist") i = 3 With rg Do Until i > Laste_Row If Not .Contains(UCase(Range("h" & i).Value)) Then .Add UCase(Range("h" & i).Value) i = i + 1 Loop arr = .toarray End With m = 3 For i = LBound(arr) To UBound(arr) For k = 3 To Laste_Row% If Sheets("data").Cells(k, "H") = arr(i) Then With Sheets("data2").Cells(m, 1) .Value = Sheets("data").Cells(k, "A") .Offset(, 1) = Sheets("data").Cells(k, "Y") .Offset(, 2) = Sheets("data").Cells(k, "H") m = m + 1 End With End If Next Next Set rg = Nothing: Erase arr End Sub

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

100%100 True لكن ادرج ماكرو البحث من خلال الحروف (الازار الحمراء) في صفحة All in Order وذلك من اجل سرعة التفتيش عن اسماء بحرف معين

تم العديل على الماكرو ليتناسب مع ما تريد الاعمدة حيث كلمات معلومة1 /معلومة 2 الخ... (يجب اخفائها من أجل ملاحظة البيانات جيداً) يمكنك اظهارها اذا كانت ضرورية حجم الملف كبير جداً (حوالي 16 ميغا مضغوطاً) لذلك لم استطع رفعه فقط ادرج هذا الكود في ملف تجريبي (نسخة ثانية من نفس الملف) عندك وقم بتجربته (اشدد على النسخة الاحتياطية ربما كان هناك اخطاء و كما تعرف لا يمكن التراجع (Undo) بعد تنفيذ الماكرو) Option Explicit Sub Salim_Code() Rem Created By Salim Hasbaya On 21/3/2020 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim All As Worksheet Dim Source_sh As Worksheet Set All = Sheets("All_In Order"): Set Source_sh = Sheets("data1") Dim RgD As Range, c As Range Dim st$, t$, Mon_array() Dim m%, lr%, lrc%, Er%, lc%, lastRo_data1% lastRo_data1 = Source_sh.Cells(Rows.Count, "D").End(3).Row If lastRo_data1 <= 3 Then Exit Sub Set RgD = Source_sh.Range("D4:D" & lastRo_data1) Mon_array = Array("ا", "ب", "ت", "ث", "ج", "ح", "خ", "د", "ذ", _ "ر", "ز", "س", "ش", "ص", "ض", "ط", "ظ", "ع", "غ", "ف", _ "ق", "ك", "ل", "م", "ن", "ه", "و", "ي") With All .Range("B5").Resize(9999, 11 * 28).ClearContents For Each c In RgD t = Mid(Trim(c), 1, 1) st = Left(t, 1) If st = "أ" Or st = "آ" Or st = "إ" Then st = "ا" m = Application.Match(t, Mon_array, 0) If Not IsError(m) Then lc = (m - 1) * 11 + 3 lr = Application.Max(5, .Cells(Rows.Count, lc).End(xlUp).Row + 1) .Cells(lr, lc - 1).Value = lr - 4 .Cells(lr, lc).Resize(1, 7).Value = _ c.Offset(, -2).Resize(1, 7).Value .Cells(lr, lc + 7).Value = Source_sh.Cells(c.Row, "o") .Cells(lr, lc + 8).Value = Source_sh.Cells(c.Row, "AJ") Else: Er = Er + 1: End If Next .Columns.AutoFit .Range("a1").ColumnWidth = 22 End With MsgBox "تم بحمد الله" & IIf(Er > 0, vbCr & Application.Rept("=", 30) & vbCr & "عدد الاسماء الخطا غير المرحلة" & vbCr & Er, "") Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

جرب هذا الكود تم تغيير اسم الورقة الاخير ة الى "All_In Order" Option Explicit Sub Salim_Code() 'كود الاستاذ الخالدي ترحيل البيانات حسب الحروف الهجائية Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim All As Worksheet Dim Source_sh As Worksheet Set All = Sheets("All_In Order"): Set Source_sh = Sheets("data1") Dim RgD As Range, c As Range Dim st$, t$, Mon_array() Dim m%, lr%, lrc%, Er%, lc%, lastRo_data1% lastRo_data1 = Source_sh.Cells(Rows.Count, "D").End(3).Row If lastRo_data1 <= 3 Then Exit Sub Set RgD = Source_sh.Range("D4:D" & lastRo_data1) Mon_array = Array("ا", "ب", "ت", "ث", "ج", "ح", "خ", "د", "ذ", _ "ر", "ز", "س", "ش", "ص", "ض", "ط", "ظ", "ع", "غ", "ف", _ "ق", "ك", "ل", "م", "ن", "ه", "و", "ي") With All .Range("B5").Resize(9999, 11 * 28).ClearContents For Each c In RgD t = Mid(Trim(c), 1, 1) st = Left(t, 1) If st = "أ" Or st = "آ" Or st = "إ" Then st = "ا" m = Application.Match(t, Mon_array, 0) If Not IsError(m) Then lc = (m - 1) * 11 + 3 lr = Application.Max(5, .Cells(Rows.Count, lc).End(xlUp).Row + 1) .Cells(lr, lc - 1).Value = lr - 4 .Cells(lr, lc).Resize(1, 8).Value = c.Resize(1, 8).Value Else: Er = Er + 1: End If Next .Columns.AutoFit .Range("a1").ColumnWidth = 22 End With MsgBox "تم بحمد الله" & IIf(Er > 0, vbCr & Application.Rept("=", 30) & vbCr & "عدد الاسماء الخطا غير المرحلة" & vbCr & Er, "") Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub tarhil_by_lettrs.xlsb

في الملف الذي رفعنه لك اكتب في الخلية G1 ي 250 و في الخلية G2 ي 350 وترى النتيجة

بالمناسبة جرب تنفيذ هذا الكود و ترى العجائب Sub ARange_sheets() Dim t%, i% Dim col As Object, itm t = Sheets("Main").Index Set col = CreateObject("System.Collections.Arraylist") On Error Resume Next For i = t + 1 To Sheets.Count col.Add CInt(Sheets(i).Name) Next On Error GoTo 0 If col.Count Then col.Sort: col.Reverse For Each itm In col Sheets(itm & "").Move after:=Sheets(t) Next End If Set col = Nothing End Sub

في هذه الجزئية من الكود فقط اجعل الحلقة التكرارية تبدأ من الرقم 4 ( وهو رقم الصفحة الني يبدأ الكود عمله منها)

تم اعادة الرفع أعمل على ملف اخر يمكنه العد تنازلياً من رقم معين حتى الصفر (اذا معك وقت استاذ علي هل يمكن المساعدة)

مؤقت بسيط يجعل اكسل يحصي لك الثواني حتى رقم معين تحدده بنفسك ممكن استعماله عند طرح اسئلة معينه و الاجابة مطلوبة خلال فترة لا تتعدى هذا الرقم My_timer.xlsm

تم التعديل Option Explicit Sub SUPER_ADV_FILTER() 'كود الاستاذ سليم حاصبيا يقوم بترحيل الطلبة حسب رقم القيد ويفتح ورقة باسم رقم قيده Application.ScreenUpdating = False Dim i% Dim y$, m%, K%, RO%, lr Dim MY_Sht As Worksheet Dim WS As Worksheet: Set WS = Sheets("Main") Dim rg As Object Dim rg_to_copy As Range, Ful_rg As Range Set rg_to_copy = WS.Range("A10").CurrentRegion Set rg = CreateObject("System.Collections.Arraylist") lr = WS.Cells(Rows.Count, 1).End(3).Row With rg i = 11 Do Until i > lr If Not .contains(CLng(WS.Range("b" & i).Value)) _ And WS.Range("B" & i).Value <> "" Then _ .Add CLng(WS.Range("B" & i).Value) i = i + 1 Loop .Sort For i = 0 To .Count On Error Resume Next y = CStr(.Item(i)) If Len(Sheets(y).Name) = 0 Then Sheets.Add after:=Sheets(Sheets.Count) ActiveSheet.Name = y End If On Error GoTo 0 Next End With Set rg = Nothing For i = 2 To Sheets.Count Sheets(i).Cells.Clear Sheets(i).Range("T1") = "رقم القيد" Sheets(i).Range("T2") = Sheets(i).Name rg_to_copy.AdvancedFilter 2, Sheets(i).Range("T1:T2"), Sheets(i).Range("A3") Sheets(i).Range("T1:T2") = vbNullString Set Ful_rg = Sheets(i).Range("a3").CurrentRegion RO = Ful_rg.Rows.Count If RO > 1 Then Sheets(i).Range("a4").Resize(RO - 1).Formula = _ Evaluate("Row(1:" & RO - 1 & ")") Sheets(i).Columns("B:R").AutoFit End If Next '++++++++++++++++++++++++++++++++++++ Set MY_Sht = Nothing: Set WS = Nothing Set rg = Nothing: Set rg_to_copy = Nothing Set Ful_rg = Nothing '++++++++++++++++++++++++++++++ Application.ScreenUpdating = True End Sub الملف من جديد My_tarhil.xlsm

وتحيا مصر ام الدنيا مع تأييدي المطلق لهذه الكلمة أقول أنا لبناني "تحيا الثورة" وربنا يحفظ بلد الأرز الخالد و كلّنا للوطن

تم التعديل كما تريد Option Explicit Sub Create_Sheet_WITH_HYPER() Rem =======>> CREATED BY SALIM HASBAYA ON 20/3/2020 Dim Tg As Worksheet Dim i%, My_name$ Dim RGA As Range, Var_Rg As Range Dim Final_Rg As Range, Ro% Application.ScreenUpdating = False Set RGA = Salim.Range("C8").CurrentRegion.Columns(1) If Salim.AutoFilterMode Then Salim.Range("c8").CurrentRegion.AutoFilter End If Application.DisplayAlerts = False For Each Tg In Sheets If Tg.Name <> "Salim" Then Tg.Delete Next Tg Application.DisplayAlerts = True For i = 4 To 6 'تستطيع ان تغير الرقم 7 الى اي رقم اقل من 72 (عدد الأعمدة+4) Set Var_Rg = Salim.Cells(8, i).CurrentRegion.Columns(i - 2) Var_Rg.AutoFilter 1, Criteria1:="<>" If Len(Salim.Cells(8, i)) > 30 Then My_name = Left(Salim.Cells(8, i), 30) Else My_name = Salim.Cells(8, i) End If Sheets.Add(after:=Sheets(Sheets.Count)).Name = My_name With ActiveSheet RGA.SpecialCells(12).Copy .Range("B2") Var_Rg.SpecialCells(12).Copy .Range("C2") .Range("B:C").Columns.AutoFit .Hyperlinks.Add Anchor:=.Range("E2"), Address:="", SubAddress:= _ "Salim!A9", TextToDisplay:="Goto SALIM" End With Set Final_Rg = ActiveSheet.Range("B2").CurrentRegion Ro = Final_Rg.Rows.Count If Ro > 1 Then With ActiveSheet .Range("A2") = "N#" .Range("A" & Ro + 2).Offset(, 1) = "Sum" .Range("A3").Resize(Ro - 1) = Evaluate("Row(1:" & Ro & ")") .Range("A" & Ro + 2).Offset(, 2).Formula = "=SUM(C3:C" & Ro + 1 & ")" .Range("A" & Ro + 2).Offset(, 2).Value = _ .Range("A" & Ro + 2).Offset(, 2).Value .Range("B2:b3").Copy .Range("A2").Resize(Ro).PasteSpecial Paste:=xlPasteFormats .Range("A" & Ro + 2).Resize(, 3).PasteSpecial Paste:=xlPasteFormats End With Application.CutCopyMode = False End If Salim.Range("C8").CurrentRegion.AutoFilter '============================ Next Salim.Select Application.ScreenUpdating = True End Sub الملف مرفق من جديد My_NEW_filter.xlsm

جرب هذا الكود Option Explicit Sub find_Over_Three() Dim R%, i% With Range("Bq5").Resize(187, 2) .ClearContents .Interior.ColorIndex = xlNone End With R = Cells(Rows.Count, 1).End(3).Row With Range("Bq5").Resize(R - 4) .Formula = "=COUNTIF(B5:BP5,""شخصى"")" .Value = .Value End With For i = 5 To R If Cells(i, "Bq") > 3 Then Cells(i, "Bq").Interior.ColorIndex = 6 End If Next End Sub الملف مرفق April.xlsm

بعد اذن الاخ علي خيار ثاني في الخلية F10 هذه المعادلة =SUMPRODUCT($D$5:$D$7,$E$5:$E$7)*$F$9 في الخلية F11 هذه المعادلة =SUMPRODUCT($D$5:$D$7,$E$5:$E$7)*(1-$F$9) file included 203.xlsx

See This file calculation.xlsx