سليم حاصبيا

و اي مساعدة تترقب بدون ملف مرفق هل لدى احد من الاساتذة الوقت لإنشاء ملف لك يحتوي على ما تريده بالاضافة الى اسماء الموظفين و عدد ايام عمل كل واحد كل في شهر وفي النهاية يمكن ان يكون الملف صحيحاً وفي أغلب الاحيان لا (انه مجرد تضييع للوقت) لذلك عليك برفع ملف يحتوي على بعض الاسماء في صفحة مستقلة مع دوام كل واحد من الموظفين مع مقدار راتبه و رفع الملف للمعالجة

حيث ان الداتا عندك لا تشكل جدولاً للاكسل (هناك خلايا مدمجة ويجب ان يكون بجانب الجدول عامود فارغ وفوقه صف فارغ) تم ادراج صف فارغ (رقم 7) وعامود فارغ B ليفصل الجدول عن بقية الخلايا ) تم انشاء ملف جديد بما تريد (للانتقال الى اي ورقة فقط اضغط DoubleClick على اسمها من الورقة Salim ) الكود Option Explicit Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim My_name$ On Error Resume Next If Not Intersect(Target, Range("d8:Pb8")) Is Nothing _ And Target.Count = 1 Then My_name = Left(Target, 30) Sheets(My_name & "").Select End If End Sub '++++++++++++++++++++++++++++++++++++++++++++++++++++++ Option Explicit Sub Create_Sheet() Dim Tg As Worksheet Dim i%, My_name$ Dim RGA As Range, Var_Rg As Range 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 7 'تستطيع ان تغير الرقم 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 Salim.Range("C8").CurrentRegion.AutoFilter '============================ Next Salim.Select End Sub الملف مرفق My_filter.xlsm

يا اخي عندك 67 عامود وبالتالي 67 صفحة زيادة اضافة الى صفحة لكل عميل مما يزيد عدد الصفحات كثيراً (100 صفحة تقريباً) و يثقل البرنامج ويسبب ببطئه

كان من الواجب عليك حفظ الملكية الفكرية التي هي من اساسيات هذا المنتدى و اعلان اسم من وضع لك الكود في الملف ربما كان الحل في الشيت Repport من هذا الملف Saerch_by_column.xlsm

تصحيح بسيط With sh.Range("B7").Resize(m - 7, 13) .Borders.LineStyle = 1 .HorizontalAlignment = 1 .InsertIndent 1 With .Font .Bold = True .Size = 14 End With '++++++++++++++++++++++++++++++++++++++++++++++++++++++ ' الرقم 10 هنا يرمز الى رقم العامود في الجدول حيث يوجد التاريخ 'أقصد العمود K .Columns(10).NumberFormat = "yyyy/m/d" '+++++++++++++++++++++++++++++++++++++++++++++++++++++++ End With End Sub

أضف هذا العبارة في نهاية الكود قبل End With الأخيرة .Value = .Value لتصبح نهاية الكود هكذا With sh.Range("B7").Resize(m - 7, 13) .Borders.LineStyle = 1 .HorizontalAlignment = 1 .InsertIndent 1 With .Font .Bold = True .Size = 14 End With .Value = .Value End With End Sub

الخطأ مطبعي في الــ Dim يجب كتابة $targt و ليس &targt Dim myArray, arr(11), targt$

هذا الماكرو يقوم بما تريد Option Explicit Option Base 1 Sub My_code() Dim m%, k%, lr%, i% Dim Main As Worksheet, sh As Worksheet Dim myArray, arr(11), targt$ Set Main = Sheets("Allstudents") Set sh = Sheets("from.school") sh.Range("B7:M1000").Clear targt = "from*" lr = Main.Cells(Rows.Count, "D").End(xlUp).Row m = 7 For i = 3 To 13 arr(i - 2) = i Next myArray = Array(38, 4, 5, 27, 13, 16, 18, 19, 20, 21, 22) For i = 5 To lr If Main.Cells(i, "AD") Like "*" & targt Then For k = 1 To 11 sh.Cells(m, arr(k)) = Main.Cells(i, myArray(k)) Next m = m + 1 End If Next With sh.Range("B7").Resize(m - 7, 13) .Borders.LineStyle = 1 .HorizontalAlignment = 1 .InsertIndent 1 With .Font .Bold = True .Size = 14 End With End With End Sub الملف مرفق My_data .xlsm

عند اذن يجب استعمال هذا الماكرو Option Explicit Sub ADD_S_with_Hyper() 'code to add Sheets One Time WITH HYPERLINKS 'Crated By Salim Hasbaya On 17/03/2020 Dim rg As Range, Rg_copy As Range Dim Title_rg As Range, Past_rg As Range Dim S As Worksheet Dim LB%, K%, i% Dim x Dim ws As Worksheet Set S = Sheets("Salim") Set Title_rg = S.Range("a6").Resize(2, 67) Application.ScreenUpdating = False LB = S.Cells(Rows.Count, 2).End(3).Row For Each rg In S.Range("B8:B" & LB) If rg.Value <> "" Then If Not Application.Evaluate("ISREF('" & rg.Value & "'!A1)") Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = rg.Value With ActiveSheet .Hyperlinks.Add Anchor:=.Range("D1"), Address:="", SubAddress:= _ "SALIM!B2", TextToDisplay:="Goto SALIM" .Cells(1, 2) = rg .Columns("A:A").AutoFit .Columns("D:D").AutoFit End With End If End If Next rg With Sheets("Salim") .Hyperlinks.Delete For i = 8 To LB x = Application.CountIf(S.Range("B2:B" & i), S.Range("B" & i)) If x = 1 Then .Hyperlinks.Add Anchor:=.Range("B" & i), Address:="", SubAddress:= _ "'" & .Range("B" & i) & "'!B1", TextToDisplay:=.Range("B" & i).Value S.Range("B" & i).Font.Underline = False S.Range("B" & i).Font.Size = 16 Else S.Range("B" & i).Font.Underline = False S.Range("B" & i).Font.Size = 16 End If Next .Select With S.Range("b8:b" & LB) .HorizontalAlignment = 1: .Font.ColorIndex = 1 .Font.Bold = -1: .InsertIndent 1 .Borders.LineStyle = 1 End With For i = 8 To LB Set ws = Sheets(S.Range("B" & i) & "") Title_rg.Copy ws.Range("a6").PasteSpecial Set Rg_copy = S.Range("A" & i) Set Past_rg = ws.Range("A8") Call give_data(Rg_copy, Past_rg, 67) Application.CutCopyMode = False Next Application.ScreenUpdating = True End With End Sub '++++++++++++++++++++++++++++++++ Sub give_data(S_rg As Range, Target_rg As Range, n As Integer) S_rg.Resize(, n).Copy Target_rg.PasteSpecial Target_rg.Offset(, 1).Resize(, n - 1).Columns.AutoFit End Sub الملف من جديد ISHAAR_2.xlsm

جرب هذا الماكرو (تسمية اول شيت بـــ Salim) تم التقليل من عدد الصفوف لمراقبة عمل الماكرو (يمكنك اضافة اي عدد من الصفوف ثم الضغط على الزر Add Hypers ) Option Explicit Sub ADD_S_with_Hyper() 'code to add Sheets One Time WITH HYPERLINKS 'Crated By Salim Hasbaya On 17/03/2020 Dim Rg As Range Dim S As Worksheet Dim LB%, K%, i% Dim x Dim ws As Worksheet Set S = Sheets("Salim") Application.ScreenUpdating = False LB = S.Cells(Rows.Count, 2).End(3).Row For Each Rg In S.Range("B8:B" & LB) If Rg.Value <> "" Then If Not Application.Evaluate("ISREF('" & Rg.Value & "'!A1)") Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = Rg.Value With ActiveSheet .Hyperlinks.Add Anchor:=.Range("D1"), Address:="", SubAddress:= _ "SALIM!B2", TextToDisplay:="Goto SALIM" .Name = Rg .Cells(1, 1) = Rg .Columns("A:A").AutoFit .Columns("D:D").AutoFit End With End If End If Next Rg With Sheets("Salim") .Hyperlinks.Delete For i = 8 To LB x = Application.CountIf(S.Range("B2:B" & i), S.Range("B" & i)) If x = 1 Then .Hyperlinks.Add Anchor:=.Range("B" & i), Address:="", SubAddress:= _ "'" & .Range("B" & i) & "'!B1", TextToDisplay:=.Range("B" & i).Value S.Range("B" & i).Font.Underline = False S.Range("B" & i).Font.Size = 16 Else S.Range("B" & i).Font.Underline = False S.Range("B" & i).Font.Size = 16 End If Next .Select With S.Range("b8:b" & LB) .HorizontalAlignment = 1: .Font.ColorIndex = 1 .Font.Bold = -1: .InsertIndent 1 .Borders.LineStyle = 1 End With Application.ScreenUpdating = True End With End Sub الملف مرفق ISHAAR.xlsm

ارفع الملف نفسه لمعرفة اداء الكود وعدم ظهور احرف غريبة

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

تم التعديل على الكود Sub transfer_Unique_New() Dim D As Worksheet, R As Worksheet Dim RoD%, RoR%, I%, m%, ky Dim RGD As Range, RGR As Range Dim Arr_1, Arr_2, Arr_3 Dim dic_1 As Object Dim dic_2 As Object Dim dic_3 As Object Set D = Sheets("Data"): Set R = Sheets("Repport") Set RGD = D.Range("a2").CurrentRegion: RoD = RGD.Rows.Count Set RGD = RGD.Offset(1).Resize(RoD - 1).Columns(11) Set RGR = R.Range("A2").CurrentRegion: RoR = RGR.Rows.Count Set dic_1 = CreateObject("Scripting.Dictionary") Set dic_2 = CreateObject("Scripting.Dictionary") Set dic_3 = CreateObject("Scripting.Dictionary") If RoR > 1 Then Set RGR = RGR.Offset(1).Resize(RoR - 1) RGR.ClearContents End If For I = 1 To RoD - 1 If Len(RGD.Cells(I)) > 1 Then x = RGD.Cells(I).Row Arr_1 = Application.Transpose(D.Cells(x, 1).Resize(, 3)) Arr_1 = Application.Transpose(Arr_1) Arr_1 = Join(Arr_1, "*") '''''''''''''''''''''''''''''''' Arr_2 = Application.Transpose(D.Cells(x, 4).Resize(, 6)) Arr_2 = Application.Transpose(Arr_2) Arr_2 = Join(Arr_2, "*") '+++++++++++++++++++++++++++++++ Arr_3 = Application.Transpose(D.Cells(x, "j").Resize(, 2)) Arr_3 = Application.Transpose(Arr_3) Arr_3 = Join(Arr_3, "*") dic_1(RGD.Cells(I).Value) = Arr_1 dic_2(RGD.Cells(I).Value) = Arr_2 dic_3(RGD.Cells(I).Value) = Arr_3 End If Next m = 3 For Each ky In dic_1.keys R.Cells(m, 1).Resize(, 3) = Split(dic_1(ky), "*") m = m + 1 Next m = 3 For Each ky In dic_2.keys R.Cells(m, 4).Resize(, 6) = Split(dic_2(ky), "*") m = m + 1 Next m = 3 For Each ky In dic_3.keys R.Cells(m, 10).Resize(, 2) = Split(dic_3(ky), "*") m = m + 1 Next R.Range("A2").CurrentRegion.Value = R.Range("A2").CurrentRegion.Value Set dic_1 = Nothing: Set dic_2 = Nothing: Set dic_3 = Nothing Set D = Nothing: Set R = Nothing Set RGD = Nothing: Set RGR = Nothing End Sub الملف من جديد Mostakhlasat_New.xlsm

long يفتش فقط عن الارقام وانت تريد ان تفتش عن نص لأن F321112568 ليست رقماً لذا يجب كتابة Dim nat As String أو $Dim nat

مكن ان تختار اي اسم مع علامة $ مثلاُ: $Dim Mot

اكثر من مرة أكرر اسماء الصفحات يجب ان تكون باللغة الاجنبية لحسن عمل نسخ ولصق للكود (دون مشاكل اللغة) الكود Option Explicit Sub transfer_Unique() Dim D As Worksheet, R As Worksheet Dim RoD%, RoR%, I%, m%, ky Dim RGD As Range, RGR As Range Dim dic As Object, Arr Set D = Sheets("Data"): Set R = Sheets("Repport") Set RGD = D.Range("a2").CurrentRegion: RoD = RGD.Rows.Count Set RGD = RGD.Offset(1).Resize(RoD - 1).Columns(11) Set RGR = R.Range("A2").CurrentRegion: RoR = RGR.Rows.Count If RoR > 1 Then Set RGR = RGR.Offset(1).Resize(RoR - 1) RGR.ClearContents End If Set dic = CreateObject("Scripting.Dictionary") For I = 1 To RoD - 1 If Len(RGD.Cells(I)) > 1 Then Arr = Application.Transpose(D.Cells(RGD.Cells(I).Row, 1).Resize(, 11)) Arr = Application.Transpose(Arr) Arr = Join(Arr, "*") dic(Arr) = vbNullString End If Next m = 3 For Each ky In dic.keys R.Cells(m, 1).Resize(, 11) = Split(ky, "*") m = m + 1 Next R.Range("A2").CurrentRegion.Value = R.Range("A2").CurrentRegion.Value Set dic = Nothing: Set D = Nothing: Set R = Nothing Set RGD = Nothing: Set RGR = Nothing End Sub الملف مرفق Mostakhlasat.xlsm

في كل الاكواد داخل الملف استبدل حرف A الى اسم العامود الذي تريده

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

تم التعديل على الماكرو بحيث يعطينا اين يوجد التكرار (اسم الصفحة مع رقم الصف) Tekrar_by_sheets_Address.xlsm

يمكن اضافة هذا الكود الى حدث Workbook ليعمل كما تريد Option Explicit Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Sh.Range("A1").CurrentRegion.Columns(1)) Is Nothing And _ Target.Count = 1 Then Colorize End If Application.EnableEvents = True End Sub الملف مرفق Auto_Tekrar_by_sheets.xlsm

Try This macro Option Explicit Sub Colorize() Dim Sh As Worksheet Set Sh = ActiveSheet Dim Rg As Range, cel As Range Dim at_c As Worksheet Dim Fadr$, Sadr$, i% Dim Act_Rg As Range, F_rg As Range Set Rg = Sh.Range("a1").CurrentRegion.Columns(1).Cells Rg.Interior.ColorIndex = xlNone For i = 1 To Sheets.Count If Sheets(i).Name <> Sh.Name Then Set Act_Rg = Sheets(i).Range("a1").CurrentRegion.Columns(1) Act_Rg.Interior.ColorIndex = xlNone For Each cel In Rg Set F_rg = Act_Rg.Find(cel, lookat:=1) If F_rg Is Nothing Then GoTo Next_cel cel.Interior.ColorIndex = 6 Fadr = F_rg.Address: Sadr = Fadr Do F_rg.Interior.ColorIndex = 6 Set F_rg = Act_Rg.FindNext(F_rg) Sadr = F_rg.Address If Sadr = Fadr Then Exit Do Loop Next_cel: Next cel End If Next i End Sub File Included Tekrar_by_sheets.xlsm

See This Video https://www.youtube.com/watch?v=z5o5ADguYb0

بالنسبة لبقية البيانات ممكن عمل ذلك بواسطة معادلة بسيطة في الخلية D11 من الشيت Final =IF($C11="","",INDEX(Salim!D$11:D$100,MATCH($C11,Salim!$C$11:$C$100,0))) لا حظ الملف بعد تنفيذ الماكرو يمكن توقفيه (بواسطة الفاصلة العليا) واخفاء شيت Salim وأعادة تسمية شيت final الى اي اسم اخر لتكون مرجعاً و بذلك تبقى شيت Salim (مع الماكرو بداخلها) للتعديلات او الاضافات تعود اليها في وقت الحاجة من صف لاخر 2.xlsm

اولاَ الملف يجب ان يحتوي على قليل من البيانات وليس اكثر من 1500 صف (انه نموذج وليس الملف الخقيقي) ثانياً أهنئك على انك فهمت ماذا يعني الجدول للاكسل وقمت بتطبيق المطلوب من ناحية عدم ادخال خلايا غريبة في الجدول وعدم ادراج خلايا مدمجة ثالثاً يجب ادراج انتائج في صفحة مستقلة (من اجل عدم الخطأ في حال تشغيل الماكرو اكثر من مرة) في هذه الحالة يتم تجاوز الصف الأعلى رابعاً تم ادراج مثال عما تريد في صفحتين الاولى للبيانات السابقة (Salim) والثانية للبيانات المحدثة (Final) تم اخفاء بعض الاعمدة وليس حذفها لرؤية النتيجة فقط الكود Option Explicit Sub From_To() Dim S As Worksheet, F As Worksheet Dim Ro%, RofC%, rofAJ%, I%, Str$ Dim Dict As Object Set S = Sheets("Salim"): Set F = Sheets("Final") Set Dict = CreateObject("Scripting.Dictionary") Ro = S.Cells(Rows.Count, 3).End(3).Row RofC = F.Cells(Rows.Count, 3).End(3).Row rofAJ = F.Cells(Rows.Count, "Aj").End(3).Row F.Range("C11:C" & RofC).ClearContents F.Range("AJ11:Aj" & rofAJ).ClearContents For I = 11 To Ro Select Case Trim(Range("AJ" & I)) Case "الاول": Str = "الثاني" Case "الثاني": Str = "الثالث" Case "الثالث": Str = "الرابع" Case "الرابع": Str = "الخامس" Case "الخامس": Str = "السادس" Case "السادس": Str = "يرحل للثانوي" Case Else: Str = "To Coll" End Select If Range("AK" & I) = "ناجح" Then Dict(Range("C" & I).Value) = Trim(Str) Else Dict(Range("C" & I).Value) = Range("AJ" & I).Value End If Next F.Range("C11").Resize(Dict.Count) = _ Application.Transpose(Dict.keys) F.Range("Aj11").Resize(Dict.Count) = _ Application.Transpose(Dict.items) Set Dict = Nothing: Set S = Nothing End Sub الملف مرفق من صف لاخر.xlsm

هذا السطر لادراج الترقيم (اختياري) اذا كنت لا تحاجه يمكن توقيفه فقط كما فعلت