سليم حاصبيا

هو هذا ما يفعله الكود الرقم الوظيفي اذا تكرر يتم ادراجه مرة واحدة فقط

استبدل في الكود عبارة With Sheets("new") بعبارة With ActiveSheet

الكود يعمل عندي بكل كفاءة ارجو شرح المشكلة عندك

ربما كان المطلوب (تم تغيير اسماء الشيتات الى اللغة الاحنبية من اجل نسخ الكود ولصقة دون مشاكل لغوية) الكود Sub fil_data_val() Dim S As Worksheet, T As Worksheet Dim dic As Object Dim i%: i = 3 Set S = Sheets("SOURCE_SH") Set T = Sheets("TARGET_SH") Set dic = CreateObject("Scripting.Dictionary") Do Until S.Range("B" & i) = vbNullString dic(S.Range("B" & i).Value) = vbNullString i = i + 1 Loop With T.Range("BK21").Validation .Delete .Add 3, Formula1:=Application.Transpose(Join(dic.keys, ",")) End With dic.RemoveAll: Set dic = Nothing End Sub الملف مرفق ADMINASTREATIONS.xlsm

جرب هذا الماكرو Option Explicit Dim arr, i, x Sub match_all() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With edit_Hyper_for_m: edit_Hyper_for_AO With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub '+++++++++++++++++++++++++++++++++++++++ Sub edit_Hyper_for_m() With Sheets("new") .[m6:m17].Hyperlinks.Delete arr = [transpose(m6:m17)] For i = LBound(arr) To UBound(arr) x = .Range("L:L").Find(arr(i), after:=.Range("L1"), lookat:=1).Row .Range("m" & i + 5).Hyperlinks.Add Anchor:=.Range("m" & i + 5), Address:="", _ SubAddress:=.Name & "!L" & x Next End With End Sub '============================ Sub edit_Hyper_for_AO() With Sheets("new") .[AO6:AO17].Hyperlinks.Delete arr = [transpose(AO6:AO17)] For i = LBound(arr) To UBound(arr) x = .Range("AN:AN").Find(arr(i), after:=.Range("AN1"), lookat:=1).Row .Range("AO" & i + 5).Hyperlinks.Add Anchor:=.Range("AO" & i + 5), Address:="", _ SubAddress:=.Name & "!AN" & x Next End With End Sub الملف مرفق MY_HYPOER.xlsm

ربما ينال اعجابك هذا الملف Create_sheet_with Hyperlink.xlsm

جرب هذا اماكرو Option Explicit Sub HYPER() Dim My_Sheet As Worksheet For Each My_Sheet In Sheets With My_Sheet .Range("A1").ClearContents .Hyperlinks.Add Anchor:=.Range("A1"), _ Address:="", SubAddress:=.Name & "!A400", _ TextToDisplay:="GOTO :" & .Name & " A400" .Range("A1").Columns.AutoFit End With Next End Sub

جرب هذه المعادلة =IF(A2="","",CHOOSE((COUNTIF($L$2:$L$50,A2)>0)+1,"عام","خاص")) الملف مرفق count+ cHOOSE.xlsx

أعد رفع الملف لانه لا يمكن تحميله على كل حال اليك هذا النموذج WITHOUT DASH.xlsx

في المرة المقبلة ارفع نموذجاً عما تريد لنفرض ان البيانات عندك في A العامود ابتداءً من A1 اكتب هذا المعادلة واسحب نزولاً =IF(A1="","",CHOOSE((N(A1)<=0)+1,A1,0)) الملف مرفق كمثال sal_book.xlsx

انت لم تقل انك تريد كل الكلمات على كل حال حاري العمل على استخراج الكل لكن بداية هل تريد ان تكون النتيجة في خلية واحدة اما كل كلمة في خلية في البداية الكل مجتمعين الكود Option Explicit Function Text_ALL(rng As Range) Dim i%, x$ With CreateObject("VbScript.RegExp") .Global = True .Pattern = "([\u0621-\u064A]+)" If Not (.Test(rng.Value)) Then _ Text_ALL = vbNullString: Exit Function For i = 0 To .Execute(rng.Value).Count - 1 x = x & " " & .Execute(rng.Value)(i).Value Next i Text_ALL = x End With End Function الملف separate_names_new.xlsm

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

جرب هذه المعادلة =SUMPRODUCT(($C$2:$C$100<>"")*($B$2:$B$100<>""))

بعد اذن اخي بن علية رب هذه الدالة Option Explicit Function Text_in(rng As Range) With CreateObject("VbScript.RegExp") .Global = True .Pattern = "([\u0621-\u064A]+)" If Not (.Test(rng.Value)) Then _ Text_in = vbNullString: Exit Function Text_in = .Execute(rng.Value)(0) End With End Function الملف مرفق separate_names.xlsm

ممكن ان يكون هذا المطلوب Quiz.xlsx

تم معالجة الامنر (انا لم انتبه الى السؤال جيداً) هذه المعادلة في الخلية B2 واسحب يساراً الى العامود D و نزولاً الى ما تشاء الى اخر صف =IFERROR(IF(ISNA(MATCH($E$3,$F$3:$F$1500,0)),"",INDEX($G$3:$I$1500,MATCH($E3,$F$3:$F$1500,0),4-COLUMNS($A$1:A1))),"") الملف مرفق CHICKAT_1.xlsx

هذه المعادلة في الخلية B2 واسحب يساراً الى العامود D و نزولاً الى ما تشاء الى اخر صف =INDEX($G$3:$I$1500,MATCH($E3,$E$3:$E$1500,0),4-COLUMNS($A$1:A1)) الملف مرفق CHICKAT.xlsx

يتم ادراجه مكان الكود القديم اليك الملف مع الكود samples_New (2).xlsm

لا جاحة للكود هنا تكفي هذه المعادلة في الخلية B11 من الشيت Sheet2 والسحب نزولاً =IF(Sheet1!A1="","",Sheet1!A1)

خفف المزيد من حجم الملف ما زال حجمه كبيراً جداً(2.6 ميغا) مع انه مضغوط فكيف اذا تم فك الضغط عنه

الماكرو الصحيح والاسرع Sub Mohamed() Dim my_sh As Worksheet Dim lr With Sheets(1) For Each f In .Range("f2", .Range("f1").End(4)) If f <> "" Then 'هذا السطر للتأكد من وجود الشيت '++++++++++++++++++++++++++++++++++++++++++++++ If Evaluate("ISREF('" & f.Value & "" & "'!A1)") = False Then _ GoTo next_f '++++++++++++++++++++++++++++++++++++++++++++++ Set my_sh = Sheets(f.Value & "") lr = my_sh.Cells(Rows.Count, 1).End(3).Row + 1 my_sh.Cells(lr, 1).Resize(, 6).Value = _ .Cells(f.Row, 1).Resize(, 6).Value End If next_f: Next End With End Sub الملف مرفق ABD KADER.xlsm

استعمل هذا الماكرو الخفيف الصف 21 يجب ان يكون فارغاً (حتى يتعرف الاكسل على الجدول بشكل صحيح) كما يجب ان لا يكون خلايا فارغة بالجدول Sub sort_me() With Range("B22").CurrentRegion .sort Key1:=.Cells(1, 5), Order1:=1, _ Key2:=.Cells(1, 8), Order2:=2, Header:=1 End With End Sub الملف مرفق tartib.xlsm

جرب هذه المعادلة =FLOOR(SUM(R4,O4,L4,I4,F4)/8,0.25) الملف مرفق takrib.xlsx

انا صراحة لا افهم لماذا هذا الاصرار على نقل البيانات من الصف السابع الى الصف حيث Lastrow خلية خلية و من ثم مسح البيانات من الصف السابع خلية خلية ايضاً افترض انه عندنا 100 خلية ( ان لم اقل 1000) في كل صف فهل نتفع هذه الطريقة ؟؟؟ (كتابة 100 سطر للنقل و 100 سطر للمسح) اكيد كلا وجدت الدالة Resize لعمل ذلك بخظوة واحدة اليك هذا المثال :(الرقم 9 في الكود )هو عدد الخلايا في الصف السابع Private Sub insertbutton_Click() Dim nextRow As Long With Sheets("sheet1") nextRow = .Range("C10000").End(xlUp).Row + 1 .Range("c" & nextRow).Resize(, 9).Value = _ .Range("c7").Resize(, 9).Value .Range("c7").Resize(, 9).Value = vbNullString End With End Sub

يفترض عدم وجود اعمدة فارغة او صفوف فارغة في البيانات الاساسية