سليم حاصبيا

حيث انك لم ترفع ملفاُ للعمل عليه ارفق لك هذا النموذج_(يمكنك تعديل الكود كما تراه مناسباً) Hide_spec_sheet.xlsm

المعادلات تعمل بشكل جيد عندي (لا اعلم ما السبب عندك) STORE-ITEM SSH2018 salim1.xlsm

جرب هذا الملف OSOL3 salim.xls

جرب هذا الملف الكود Option Explicit Sub copy_filter() Application.ScreenUpdating = False Dim My_rg As Range Dim x%, i%, a(), k%: k = 1 Dim lr%: lr = Sheets("ALL LEGAL CA").Cells(Rows.Count, 1).End(3).Row Set My_rg = Sheets("ALL LEGAL CA").Range("a1:AJ" & lr) Sheets("salim").Range("a1").CurrentRegion.Resize(500).Clear a = Array(2, 17, 22, 23, 27, 34, 36) For i = 0 To 6 My_rg.Columns(a(i)).SpecialCells(xlCellTypeVisible).Copy _ Sheets("Salim").Cells(1, k) k = k + 1 Next Erase a Application.ScreenUpdating = True End Sub الملف مرفق Kridy.xls

تم معالجة الامر STORE-ITEM SSH2018 salim.xlsm

لك ما تريد salim_formula1.xls

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

بعد اذن اخي زيزو هذا الملف salim_formula.xls

انظر الى اخر مشاركة لي على هذا العنوان https://www.officena.net/ib/topic/82985-فتح-شيت-جديد-بمجرد-كتابة-الإسم-فى-خلية/?tab=comments#comment-528117

جرب هذا الملف Vice_versa Hyper.xlsm

الموضوع جيد و الى الامام لكن عندي ملاحظتين ارجو تقبلها: 1- لا ضرورة لتحديد صفحة مجمد ثم نسخها (يكفي نسخها فقط) 2-في حال ادراج اسم موجود في العامود C او ان الخلية فارغة يحصل خطأ بالكود لذلك لتفادي هذا الخطأ يمكن اضافة شرط على الكود وهو ان عدد مرات تكرار الاسم لا يتجاوز الواحد او ان الخلية غير فارغة ليبدو الكود يهذا الشكل Private Sub Worksheet_Change(ByVal Target As Range) Dim cont%, lr If Target.Column = 3 Then lr = Sheets(1).Range("c" & Rows.Count).End(xlUp).Rows.Value cont = Application.CountIf(Range("c:c"), Target) If cont > 1 Or IsEmpty(Target) Then GoTo Exit_Me Sheets("Mohamed").Copy after:=Sheets(Sheets.Count) Sheets(Sheets.Count).name = lr Sheets(Sheets.Count).[b1].Value = lr End If Exit_Me: End Sub

قم بمسح هذين السطرين من الكود Sheets("Templete").Select With Sheets("Templete") و استبدالهما بهذا With Activesheet و اينما ترى sheets("Templete") استبدلها بـــــ ِActivesheet في النهاية الماكرو يهذا الشكل Sub add_formula() With Sheets("index") .Range("L4").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,2),"""")" End With 'Sheets("Templete").Select ' With Sheets("Templete") With ActiveSheet .Range("D13").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,2),"""")" .Range("E13").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,3),"""")" .Range("F13").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,4),"""")" .Range("D13:F13").AutoFill Destination:=Range("D13:F200"), Type:=xlFillDefault End With ActiveSheet.Sort.SortFields.Clear ActiveSheet.Sort.SortFields.Add Key:=Range("C13"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveSheet.Sort .SetRange Range("B13:I200") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With add_button End Sub

جرب هذا الماكرو(يمكن اضافته الى الماكرو الاساسي اذا اردت) Sub salim_formula() Sheets("bbb").Select Dim k% Dim t$ Dim Final_Row% For k = 9 To 20 Final_Row = Cells(Rows.Count, k).End(3).Row Select Case k Case 9: t = "=SUM($D3+$E3)" Case 10: t = "=SUM($b3+$C3)" Case 12: t = "=SUM($K3+$H3)" Case 14: t = "=SUM($M3+$K3)" Case 16: t = "=SUM($O3+$M3)" Case 17: t = "=SUM($P3+$N3)" Case 18: t = "=SUM($Q3+$O3)" Case 19: t = "=SUM($R3+$P3)" Case 20: t = "=SUM($S3+$Q3)" Case Else GoTo Next_K End Select Cells(3, k).Resize(k).Formula = t Next_K: Next End Sub

كيف يمكن عمل فلترة لجدول فارغ من فضلك ادرج قليل من البيانات في الجدول (ولو كانت وهمية من 20 الى 25 صف)للعمل عليه

الماكرو يكتب بهذا الشكل Sub add_formula() With Sheets("index") .Range("L4").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,2),"""")" End With Sheets("Templete").Select With Sheets("Templete") .Range("D13").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,2),"""")" .Range("E13").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,3),"""")" .Range("F13").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,4),"""")" .Range("D13:F13").AutoFill Destination:=Range("D13:F200"), Type:=xlFillDefault End With Sheets("Templete").Sort.SortFields.Clear Sheets("Templete").Sort.SortFields.Add Key:=Range("C13"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With Sheets("Templete").Sort .SetRange Range("B13:I200") .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With add_button End Sub '===================== Sub add_button() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim i% Dim k%: k = Sheets.Count If k < 4 Then GoTo Exit_Sub For i = 4 To k Sheets("templete").Select ActiveSheet.Shapes.Range(Array("Button 3")).Select Selection.Copy Sheets(i).Select ActiveSheet.Buttons.Delete Range("a1").Select ActiveSheet.Paste Next Exit_Sub: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub '============================= الملف مرفق STORE-ITEM salim (3).xlsm

ارفع ملفاً نموذج مع قليل من الييانات (20 25 سطر) دون زركشة او تنسيق الوان تبهر النظر لمعرفة المطلوب بالضبط

ريما افضل ان يكون الملف يهذا الشكل(دون اليوزر فورم) الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim my_rg As Range Dim lrA%, lrB% lrA = Sheets("2").Cells(Rows.Count, 1).End(3).Row + 1 lrB = Sheets("2").Cells(Rows.Count, 2).End(3).Row + 1 Set my_rg = Me.Range("b2:c2") Application.EnableEvents = False If Not Intersect(Target, my_rg) Is Nothing And _ Target.Cells.Count = 1 And Not IsEmpty(Target) Then If Target.Address = "$B$2" Then Sheets("2").Cells(lrA, 1) = Target Else Sheets("2").Cells(lrB, 2) = Target End If End If Application.EnableEvents = True End Sub الملف مرفق مرحلة إدخال البيانات Salim.xlsm

المرفق يحتوي نموذجاً عما تريد فقط حاول ان تعدل بالكود ليتناسب مع المطلوب عندك with_without formula.xlsm

اكتب المعادلات الضرورية في الشيت الذي سوف تنسخ عنه (قبل تنفيذ الكود) و هذه المعادلات تذهب معه اوتوماتيكياً

هذا الماكرو البسيط Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$F$4" Then Application.EnableEvents = False Range("g:g").SortSpecial End If Application.EnableEvents = True End Sub

حيث انك لم ترفع ملفاً للعمل عليه اليط هذا المثال الذي ربما تستطيع ان تقتبس منه ما يلزم الكود Option Explicit Sub Under_line() Dim St$: St = [a1] Dim x%: x = Len(St) Dim t%, xx% Dim Op_Pos%, Cl_Pos% 'Op_pos=Open parantheses position 'Cl_pos=Close parantheses position '============================= [a1].Characters(1, Len([a1])).Font.ColorIndex = vbBlack [a1].Characters(1, Len([a1])).Font.Underline = False For t = 1 To 5000 If t > x Then Exit For Op_Pos = InStr(t, St, "(") Cl_Pos = InStr(t, St, ")") If Op_Pos = 0 Then MsgBox "not Opened paranteses to work": Exit Sub xx = Cl_Pos - Op_Pos - 1 [a1].Characters(Op_Pos + 1, xx).Font.ColorIndex = 3 [a1].Characters(Op_Pos + 1, xx).Font.Underline = True t = 1 + Len(Mid(St, 1, Cl_Pos)) Next End Sub '================================================ Sub remove_underline() [a1].Characters(1, Len([a1])).Font.ColorIndex = vbBlack [a1].Characters(1, Len([a1])).Font.Underline = False End Sub '======================================== الملف مرفق foermat between ().xlsm

معادلة واحدة توضع في كل الصفحات (من ""ناجحة " حتى "راسبة وليس لها حق الاعادة") في الخلية B11 (استعمل Ctrl+Shift+Enter و ليس Enter وحدها) اسحب المعادلة يمينا عامود واحد ونزولاً قدر ما تريد ملاجظة:كي تعمل المعادلة يجب ان يكون الملف محفوظ داخل الجهاز المعادلة =IFERROR(INDEX(Sheet1!B$11:B$27,SMALL(IF(Sheet1!$B$11:$B$27<>"",IF(TRIM(Sheet1!$C$11:$C$27)=(RIGHT(CELL("filename",$A$1),LEN(CELL("filename",$A$1))-SEARCH("]",CELL("filename",$A$1)))),ROW($B$11:$B$27)-ROW($B$11)+1)),ROWS(A$1:A1))),"") بالنسبة للمعادلة في الصفحة Sheet1 الخلية C11 نزولاً يمكن استبدالها يهذه (دون تكرار الشرط IF) =IF(D11="","",VLOOKUP(D11,{0,"ناجحة",0;1,"دور ثان",0;3,"راسبة ولها حق الاعادة",0;4,"راسبة وليس لها حق الاعادة",0},2)) الملف مرفق ALL_In One Salim.xls

اضافة هذا السظر الى الكود ActiveCell.Font.Underline = True

جرب هذا الملف تم تغيير اسم القالب الى Templete لحسن عمل الكود الكود Option Explicit Sub Create_TOC() 'Created By sakim On 21/3/2018 'Macro for Create sheets with vice_versa hyprlink 'TOC=Table Of Contents Dim my_name$ Dim x%, i%, Sh_to_copy As Worksheet: Set Sh_to_copy = Sheets("Templete") Dim my_sh As Worksheet: Set my_sh = Sheets("index") Dim LrC%: LrC = my_sh.Cells(Rows.Count, 3).End(3).Row If LrC < 4 Then LrC = 4 With Application .Calculation = xlCalculationManual .ScreenUpdating = False .DisplayAlerts = False .ScreenUpdating = False End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''' On Error Resume Next For i = 4 To LrC my_name = Sheets(i).Name If my_name = "" Then Sh_to_copy.Copy after:=Sheets(Sheets.Count) With ActiveSheet .Name = my_sh.Range("c" & i) .Range("f1") = my_sh.Range("c" & i) .Range("f2") = my_sh.Range("d" & i) End With '===================================== With my_sh .Hyperlinks.Add .Cells(i, 2), "", _ SubAddress:="'" & ActiveSheet.Name & "'!A1", _ TextToDisplay:="go to it" End With End If Next Salim_button With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True .DisplayAlerts = True .ScreenUpdating = True End With my_sh.Select End Sub Sub Salim_button() Dim cnt%: cnt = Sheets.Count Dim k% For k = 4 To cnt Sheets(k).Buttons.Delete With Sheets(k).Buttons.Add(50, 1.5, 141, 31) .OnAction = "My_Selection" .Font.Name = "Calibri" .Font.FontStyle = "Bold Italic" .Font.ColorIndex = 3 .Characters.Text = "Go_To_Index" End With Next End Sub Sub My_Selection() Sheets("index").Select End Sub '============================ الملف مرفق STORE-ITEM salim.xlsm

تم التعديل على الكود ليعمل بسرعة اكبر بكثير (9000 رقم في 2.3 ثانية) الكود Option Explicit 'Excel VBA to generate random number 'Created by Salim on 21/3/2018 Sub Generate_Uniq_Random() If ActiveSheet.Name <> "Salim" Then GoTo Exit_sub With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim myStart As Long Dim myEnd As Long Dim x As Byte Dim i As Long Dim lr_B: lr_B = Cells(Rows.Count, 2).End(3).Row If lr_B < 2 Then lr_B = 2 Range("b2:C" & lr_B).ClearContents Dim a() myStart = [G2] myEnd = [H2] ReDim a(0 To myEnd - myStart) For x = 1 To 2 If x = 1 Then With CreateObject("System.Collections.SortedList") Randomize For i = myStart To myEnd .Item(Rnd) = i Next i For i = 0 To .Count - 1 a(i) = .GetByIndex(i) Next End With Range("b2").Resize(UBound(a) + 1).Value = Application.Transpose(a) Else With CreateObject("System.Collections.SortedList") Randomize For i = myStart To myEnd .Item(Rnd) = i Next i For i = 0 To .Count - 1 a(i) = .GetByIndex(i) Next End With Range("c2").Resize(UBound(a) + 1).Value = Application.Transpose(a) End If Next Exit_sub: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق Fix_randbetween.xlsm