سليم حاصبيا

للحفاظ على الترتيب افعل كما في الصورة

تعديل بسيط على الماكرو ليظهر اسماء الشيتات Sub Uniq_items_With_Sh_Names() Dim R As Worksheet, Sw As Worksheet Dim Nme$, Rg As Range Dim cop_rg As Range Dim dic As Object, I%, m% Dim arr(), ky, t% Set R = Sheets("report") Set dic = CreateObject("Scripting.Dictionary") Set cop_rg = Range("B4").CurrentRegion Nme = R.Range("C2") If cop_rg.Rows.Count > 1 Then cop_rg.Offset(1).ClearContents End If m = 5 For Each Sw In Sheets If Sw.Name <> R.Name Then Set Rg = Sw.Range("G5", Sw.Range("G4").End(4)) For I = 1 To Rg.Rows.Count If Rg.Cells(I).Offset(, 2) = Nme Then dic(Rg.Cells(I).Value) = _ Rg.Cells(I).Offset(, 2).Value End If Next If dic.Count = 0 Then GoTo Next_Sheet For Each ky In dic.keys ReDim Preserve arr(t) If t = 0 Then arr(t) = dic(ky) & ": Sheet " & Sw.Name Else arr(t) = dic(ky) End If t = t + 1 Next With R.Cells(m, 2).Resize(dic.Count) .Value = Application.Transpose(dic.keys) .Offset(, 1) = Application.Transpose(arr) m = m + dic.Count: dic.RemoveAll: Erase arr: t = 0 End With End If Next_Sheet: Next Sw End Sub الملف من جديد Unique_item_1.xlsm

حرب هذا الماكرو Option Explicit Private Sub Workbook_SheetActivate(ByVal Sh As Object) '++++++++++++++++++++++++++++++ ' Replace Salim with the Needed Sheet's Name If Sh.Name = "Salim" Then '+++++++++++++++++++++++++++++++++ ThisWorkbook.Protect Else ThisWorkbook.Unprotect End If End Sub الملف للتجربة مرفق No_delete_special_sheet.xlsm

جرب هذا الماكرو Option Explicit Sub Uniq_items() Dim R As Worksheet, Sw As Worksheet Dim Nme$, Rg As Range Dim cop_rg As Range Dim dic As Object, I%, m% Set R = Sheets("report") Set dic = CreateObject("Scripting.Dictionary") Set cop_rg = R.Range("B4").CurrentRegion Nme = R.Range("C2") If cop_rg.Rows.Count > 1 Then cop_rg.Offset(1).ClearContents End If m = 5 For Each Sw In Sheets If Sw.Name <> R.Name Then Set Rg = Sw.Range("G5", Sw.Range("G4").End(4)) For I = 1 To Rg.Rows.Count If Rg.Cells(I).Offset(, 2) = Nme Then dic(Rg.Cells(I).Value) = _ Rg.Cells(I).Offset(, 2).Value End If Next If dic.Count = 0 Then GoTo Next_Sheet With R.Cells(m, 2).Resize(dic.Count) .Value = Application.Transpose(dic.keys) .Offset(, 1) = Application.Transpose(dic.items) m = m + dic.Count: dic.RemoveAll End With End If Next_Sheet: Next Sw End Sub الملف مرفق Unique_item.xlsm

كود ممتاز استاذ حسين لكن اسمح لي بهذه الملاحظة ،اذ لا لزوم للحلقات التكرارية لتعبئة الكومبوبوكس هذا الكود يفي بالغرض Option Explicit Private Sub ComboBox1_Change() End Sub Private Sub CommandButton1_Click() Dim lr, ctr As Object Dim sh As Worksheet Set sh = Sheets("المستفيد") lr = sh.Cells(Rows.Count, "a").End(xlUp).Row + 1 If TextBox1 = "" Or ComboBox1 = "" Or ComboBox2 = "" Or TextBox2 = "" Then _ MsgBox "عفوا يجب تعبئة جميع الحقول", vbInformation: Exit Sub With sh.Range("A" & lr) .Value = TextBox1.Value .Offset(, 1) = ComboBox1.Value .Offset(, 2) = ComboBox2.Value .Offset(, 3) = TextBox2.Value End With 'يجب التوضيح هنا ربما يكون لدينا 50 كومبوبوكس و تكس بوكس فهل نذكرها كلها؟ For Each ctr In Me.Controls If TypeName(ctr) = "TextBox" Or _ TypeName(ctr) = "ComboBox" Then ctr.Value = vbNullString End If Next End Sub '++++++++++++++++++++++++++++++++++++++++++++++++++ Private Sub UserForm_Initialize() Dim sh As Worksheet Dim sh2 As Worksheet Set sh2 = Sheets("الشهر") Set sh = Sheets("المستفيد") ComboBox1.List = sh.Range("H5", sh.Range("H4").End(4)).Value ComboBox2.List = sh2.Range("A2", sh2.Range("A1").End(4)).Value End Sub

اكتب في الكود اسم الصفحة التي تعمل عليها مكان "salim"

انا أفضل الماكرو لعمل هذا الشيء (الضفحة salim من هذا الملف) الماكرو Option Explicit Sub Chercher_Date_by_array() Dim I%, lr%, D As Object, arr(), X% Set D = CreateObject("Scripting.Dictionary") With Sheets("salim") If .Range("G1").CurrentRegion.Rows.Count > 1 Then .Range("G1").CurrentRegion.Offset(1).Clear End If lr = .Cells(Rows.Count, 3).End(3).Row For I = 2 To lr If Application.CountIf(.Range("A2:A" & I), .Range("A" & I)) = 1 Then ReDim Preserve arr(X) arr(X) = Range("B" & I) X = X + 1 End If D(.Cells(I, 1).Value) = CDate(.Cells(I, 2)) Next With .Range("G2").Resize(D.Count) .Value = Application.Transpose(D.keys) .Offset(, 1).Resize(X) = Application.Transpose(arr) .Offset(, 2) = Application.Transpose(D.Items) With .Resize(, 3) .Value = .Value .InsertIndent 1 .Borders.LineStyle = 1 .Interior.ColorIndex = 40 .Font.Bold = True .Font.Size = 16 End With End With End With Set D = Nothing: Erase arr End Sub الملف مرفق للتجربة My_sheet _Dict.xlsm

لا حاجة لرفع الملف بكامله (أكثر من 1100 صف) كان يكفي رفع نموذج عما تريد لا أكثر من 20 صف لمعاينه عمل المعادلات انظر الى هذا الملف My_sheet (1).xlsx

جرب هذا الكود Option Explicit Sub Join_array() Dim My_rg As Range, Entire_Mot$, Cel As Range Set My_rg = Union(Range("I5"), Range("C12"), Range("B13"), Range("E13"), _ Range("G13"), Range("C16"), Range("E16"), Range("H16"), _ Range("F18"), Range("H18")) For Each Cel In My_rg Entire_Mot = Entire_Mot & " " & Cel.Text Next Range("N14") = Mid(Entire_Mot, 1, Len(Entire_Mot) - 1) & "." End Sub

الاكسل لم يتمكن من الطباعة لان الطايعة غير مثبتة عندك قم اولاً يتعريف الطابعة ومن ثم تستطيع استعمالها

ضعه في الفورم form احذف اول سطر من الكود وضع مكانه Private Sub CommandButton3_Click() اذا كان رقم الزر التنفيذ 3 او استبدل 3 برقم زر التنفيذ

جرب هذا الكود Sub Print_First_Sheet_In_Selections() ''''''''''''''''Replace ".Select" By ".PrintOut" '''''''''' ActiveWindow.SelectedSheets(1).Select End Sub

جرب هذا الكود Option Explicit Sub Rrint_out() Dim sh As Worksheet For Each sh In Sheets If sh.Name Like "??" & "-##*" Then 'Choose sh.PrintPreview Or sh.PrintOut sh.PrintPreview ' sh.PrintOut End If Next End Sub

انا ارى ان هذا الكود عديم الفائدة لانه ما الغاية من ان نقول للاكسل "حدد لنا هذا النطاق و نكون قد حددناه مسبقا كي يتعرف عليه" فنحن قد حدناه مسبقاً الافضل ان نعطيه العنوان ونكلفه بتحديد النطاق المناسب (مع اعطاء رسالة في حال الخطأ) بواسطة هذا الكود Option Explicit Sub select_by_choise() Dim Reg As Object Dim i%, rg As Range Dim Inp_Box Inp_Box = InputBox("Type Your Range Address") Set Reg = CreateObject("VBScript.RegExp") With Reg .Pattern = _ "(^\s+?\$?[A-Z]+\$*?\d+\s*?:\s*?\$?[A-Z]+\$\d+\s*?$|^\$?[A-Z]+\$*?\d+\s*?$)" .IgnoreCase = True .Global = True End With On Error Resume Next Set rg = Range(Inp_Box) If Err.Number > 0 Then MsgBox "Wrong Address :" & Chr(10) & " " _ & """" & Inp_Box & """" Exit Sub End If Range(Inp_Box).Select End Sub الملف مرفق للتجربة Select_by_CHOISE_RG.xlsm

جرب هذا الكود Sub test() Dim My_RG As Range Set My_RG = Application.InputBox("Select Your Range Please", Type:=8) Range(My_RG.Address).Select End Sub Selection_by_Choise.xlsm

المعادلات باستعمال Indirect يجب ان تذكر اسم الصفحة وليس رقها الملف مرفق كنموذج KPI AIDE.xlsx

ليفهم الاكسل ان التوقيت بعد الطهر وليس صباحاَ يجب كتابة الوفت هكذا pm 2:00:00 PM

تم معالجة الامر الصفحة Salim من هذا الملف Order_Lycee_1 - Copy.xlsm

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

معادلا ت ممتازة لكن في هذه الحالة لا بد من ادراج معادلة مستقلة لكل عامود من العامود (R) الى العامود (AC) بينما في اجابتي معادلة في الخلية (R6) واحدة تكفي مع سحبها يسارا 12 عامود و نزولاً 6 صفوف (بدون عامود مساعد)

جرب هذا الملف Test2_salim.xlsx

هذا الكود ربما يساعدك Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim a, b, c a = Not Intersect(Target, Union(Range("A2:A1000"), _ Range("D2:D1000"))) Is Nothing b = Target.Cells(1) <> vbNullString c = Target.Count = 1 Application.EnableEvents = False If a * b * c <> 0 Then Target.Offset(, 1).Select End If Application.EnableEvents = True End Sub

عندما ضغطت على الزر اول مرة قام البرنامج بترتيب الصفحات واذا ضغطت مرة ثانية انت تطلب منه ان يرتبها ، لكن هي مرتبة فعلا ولذلك لا يفعل شيئاً جرب اعادة خربتتها بشكل عشوائي واضغط الزر وترى ما أقصده

هذه المعلومة لم انتبه لها " المهم انك تعرفها "

وهذا الكود يقوم بنفس العمل لكن مع عدد متغير من الصفوف يكفي ان تضع في الخلية I1 عدد الصفوف التي تريدا وتضغط على الزر Run مع تحديد نطاق الطباعة حسب الداتا التي حصلنا عليها Option Explicit Sub give_data_by_Y() 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() Dim y Set D = Sheets("data"): Set D2 = Sheets("data2") y = D.Range("i1") Laste_Row = D.Cells(Rows.Count, 1).End(3).Row D2.Cells.Clear x = (Laste_Row \ y) + 1 k = 1 ReDim arr(1 To x) For m = 1 To x arr(m) = y * (k - 1) + 3 k = k + 1 Next Ro = 3: col = 1 '++++++++++++++++++++++++++ Get The Result For k = 1 To UBound(arr) With D2.Cells(Ro, col).Resize(y) .Value = _ D.Range("A" & arr(k)).Resize(y).Value .Offset(, 1).Value = _ D.Range("B" & arr(k)).Resize(y).Value .Offset(, 2).Value = _ D.Range("G" & arr(k)).Resize(, y).Value End With D2.Cells(1, col + 3).ColumnWidth = 0.75 D2.Cells(4, col + 3).Formula = "=""""" col = col + 4 Next '++++++++++++++++++++++++++End Of The Result '__________________________Type The Titles last_col = D2.Cells(3, Columns.Count).End(1).Column Tile = Array("رقم ", "الاسم و اللقب ", "القسم") For m = 1 To last_col Step 4 D2.Cells(2, m + 3).Resize(y + 1). _ Interior.ColorIndex = 40 D2.Cells(2, m).Resize(, 3) = Tile Next '__________________________ End Of Typing The Titles '++++++++++++++++++++++++++ Format The Result With D2.Cells(2, 1).Resize(y + 1, last_col) .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) .HorizontalAlignment = 3 .Interior.ColorIndex = 6 End With n = Application.CountA(D2.Cells(2, last_col - 2).Resize(y)) If n < y Then D2.Cells(n + 2, last_col - 3).Resize(y - n + 1, 5).Clear End If '++++++++++++++++++++++++++ End Of The Format Of Result D2.PageSetup.PrintArea = D2.Range("A2").Resize(y + 1, last_col).Address Set D = Nothing: Set D2 = Nothing Erase arr: Erase Tile End Sub File Included New_std_salim_1.xlsm