سليم حاصبيا

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

تم التعديل مرة أخرى و بإضافت جديدة 1-حرية اختيار الكلمة لتلوينها و تكبير الخط فيها (الخلية F1 ) 2-حرية اخنيار لون التلوين (الخلية G1 ) 3- الكود Option Explicit Sub Regex_position(aSrting As Range, ByVal My_ExP As String) Dim rex As Object Dim Array_Pos() As Integer Dim Array_Mot() As String Dim Cnt% Dim My_Match, Sing_Match Set rex = CreateObject("Vbscript.Regexp") With rex .Pattern = My_ExP: .ignorecase = True: .Global = True End With If rex.test(aSrting) Then Set My_Match = rex.Execute(aSrting) Cnt = 0 For Each Sing_Match In My_Match ReDim Preserve Array_Pos(Cnt) ReDim Preserve Array_Mot(Cnt) Array_Pos(Cnt) = Val(Sing_Match.firstindex + 1) Array_Mot(Cnt) = Sing_Match Cnt = Cnt + 1 Next For Cnt = LBound(Array_Pos) To UBound(Array_Pos) With aSrting.Characters(Array_Pos(Cnt), Len(Array_Mot(Cnt))).Font .ColorIndex = Sheets("sheet1").Range("G1") .Size = 20: .Bold = True End With Next End If End Sub '++++++++++++++++++++++++++++++++++++ Sub Colorize_Please() Application.ScreenUpdating = False Dim st, cel As Range st = "(?:^|\W)" & Range("F1") & "(?:$|\W)" 'With Range("a1:a13") With Sheets("Sheet1").UsedRange .Characters.Font.ColorIndex = 1 .Font.Bold = False .Font.Size = 16 End With 'For Each cel In Range("a1:a13") For Each cel In Sheets("Sheet1").UsedRange Call Regex_position(cel, st) Next With Sheets("Sheet1").Range("F1:G1").Font .ColorIndex = 1: .Bold = True: .Size = 20 End With Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++++++++++++++ Sub reset_me() With Sheets("Sheet1").UsedRange.Font .ColorIndex = 1: .Bold = False: .Size = 16 End With With Sheets("Sheet1").Range("F1:G1").Font .ColorIndex = 1: .Bold = True: .Size = 20 End With End Sub الملف مرفق All_Saerch_New.xlsm

ربما ينفع هذا الكود Private Sub CommandButton1_Click() Dim n%, Ro%, i%, x% Dim a, b As Boolean, c As Boolean Dim st1$, st2$, st3$ st1 = "سدد": st2 = "انجز": st3 = "تم" CommandButton2_Click n = Sheets.Count For i = 1 To n With Sheets(i) .Cells.EntireRow.Hidden = False Ro = .Cells(Rows.Count, "J").End(3).Row For x = 1 To Ro a = Cells(x, "J") = st1: b = .Cells(x, "B") = st2 c = .Cells(x, "B") = st3 If b Or c Then .Cells(x, "B").EntireRow.Hidden = True If a Then .Cells(x, "J").EntireRow.Hidden = True Next x End With Next i Unload Me End Sub '++++++++++++++++++++++++++++++++++++++ Private Sub CommandButton2_Click() Dim M%, t% M = Sheets.Count For t = 1 To M Sheets(t).Cells.EntireRow.Hidden = False Next t Unload Me End Sub Hide_Rows.xlsm

جرب هذا الكود Option Explicit Dim La%, x% Dim SW As Worksheet Sub find_in(Rg As Range) Dim obj As Object Dim Mth, i, p, k% With Rg .Characters(1, Len(Rg)).Font.Color = 1 .Font.Bold = False End With Set obj = CreateObject("Vbscript.Regexp") With obj .Pattern = "\b(in)\b" .Global = True .ignorecase = True .MultiLine = True End With If obj.test(Rg) Then Set Mth = obj.Execute(Rg) For i = 0 To Mth.Count - 1 p = InStr(1 + k, Rg, Mth(i)) Rg.Characters(p, 2).Font.ColorIndex = 5 Rg.Characters(p, 2).Font.Bold = True k = Len(Rg) - p Next End If End Sub '++++++++++++++++++++++++++++++++++++ Sub Colorize() Set SW = Sheets("Sheet1") La = SW.Cells(Rows.Count, 1).End(3).Row For x = 1 To La If SW.Cells(x, 1) <> vbNullString Then Call find_in(SW.Range("A" & x)) End If Next End Sub '++++++++++++++++++++++++++++++++ Sub reset() Set SW = Sheets("Sheet1") La = SW.Cells(Rows.Count, 1).End(3).Row For x = 1 To La If SW.Cells(x, 1) <> vbNullString Then With SW.Cells(x, 1) .Characters(1, Len(.Value)).Font.Color = 1 .Font.Bold = False End With End If Next End Sub الملف مرفق Saerch_In.xlsm

لقد قمت بحذف الملف من حهازي رجاء ارفع ملفاً جديداً يحتوي على قليل من البيانات العشوائية مع الكلمات التي تريدها ان تختفي صفوفها ( في كل صفحة 10 صفوف لا أكثر)

تفضل اخي ابو الحسن Sheet_Name.xlsm

اللغة العربية دائما ما تسبب مشاكل في الاكواد (انصح بعدم استعمالها) لذلك تم تغيير اسماء الازرار الى SHP_1 و SHP_2 الكود Sub Button02() Dim arr(1), i% arr(0) = "SHP_1": arr(1) = "SHP_2" For i = 0 To 1 ActiveSheet.Shapes.Range(Array(arr(i))).Select ' +++++++++++++++++++++++++++++ If Selection.Text = "Show" Then Rows("5:20").EntireRow.Hidden = False With Selection .Font.ColorIndex = 2 .Text = "Hide" .ShapeRange.Fill.ForeColor.RGB = _ RGB(192, 0, 0) End With Else Rows("5:20").EntireRow.Hidden = True With Selection .Font.ColorIndex = 6 .Text = "Show" .ShapeRange.Fill.ForeColor.RGB = _ RGB(0, 0, 255) End With End If '++++++++++++++++++++++++++++++++ Next [A1].Select End Sub الملف مرفق Double_but.xlsm

ربما ينال الاعجاب هذا الملف 1-لا يتم تكرار الأسماء 2-تحديد المجموع لكل اسم الكود Sub transfer_data_with_sum() Dim S1 As Worksheet, S2 As Worksheet Dim Rg1 As Range, x As Range Dim Dic As Object Set S1 = Sheets("ورقة1"): Set S2 = Sheets("ورقة2") If S2.Range("A1").CurrentRegion.Rows.Count > 1 Then _ S2.Range("A1").CurrentRegion.Offset(1) _ .Resize(S2.Range("A1").CurrentRegion.Rows.Count - 1) _ .Clear Set Dic = CreateObject("Scripting.Dictionary") Set Rg1 = S1.Range("A1").CurrentRegion If Rg1.Rows.Count = 1 Then Exit Sub Set Rg1 = Rg1.Offset(1).Resize(Rg1.Rows.Count - 1) For Each x In Rg1.Columns(2).Cells Dic(x.Value) = Val(Dic(x.Value)) + Val(x.Offset(, 1)) Next x If Dic.Count = 0 Then Exit Sub With S2.Range("B2").Resize(, Dic.Count) .Value = Dic.keys .Offset(1) = Dic.Items End With S2.Range("A2") = "الإسم": S2.Range("A3") = "المجموع" With S2.Range("a2").Resize(2, S2.Range("A1").CurrentRegion.Columns.Count) .InsertIndent 1: .Borders.LineStyle = 1 .Font.Size = 14: .Font.Bold = True .Rows(1).Interior.ColorIndex = 19 .Rows(2).Interior.ColorIndex = 28 End With End Sub الملف مرفق Mashri3 _with_Sum.xlsm

جرب هذا الملف الكود Option Explicit Sub transfer_data() Dim S1 As Worksheet, S2 As Worksheet Dim Rg1 As Range Set S1 = Sheets("ورقة1"): Set S2 = Sheets("ورقة2") If S2.Range("A1").CurrentRegion.Rows.Count > 1 Then _ S2.Range("A1").CurrentRegion.Offset(1) _ .Resize(S2.Range("A1").CurrentRegion.Rows.Count - 1).Clear Set Rg1 = S1.Range("A1").CurrentRegion If Rg1.Rows.Count = 1 Then Exit Sub Set Rg1 = Rg1.Offset(1).Resize(Rg1.Rows.Count - 1) Rg1.Columns(2).Copy S2.Range("A2").PasteSpecial Paste:=xlPasteValues, Transpose:=True Application.CutCopyMode = False With S2.Range("A1").CurrentRegion.Rows(2) .InsertIndent 1: .Borders.LineStyle = 1 .Font.Size = 14: .Font.Bold = True .Interior.ColorIndex = 19: .Cells(1, 1).Select End With End Sub الملف مرفق Mashri3.xlsm

جرب هذا الكود Private Sub CommandButton1_Click() Dim n%, Ro%, i%, x% n = Sheets.Count For i = 1 To n With Sheets(i) .Cells.EntireRow.Hidden = False Ro = .Cells(Rows.Count, "J").End(3).Row For x = 1 To Ro If .Cells(x, "J") = "سدد" Then .Cells(x, "J").EntireRow.Hidden = True End If Next x End With Next i Unload Me End Sub '++++++++++++++++++++++++++++++++++++++ Private Sub CommandButton2_Click() Dim n%, i% n = Sheets.Count For i = 1 To n Sheets(i).Cells.EntireRow.Hidden = False Next i Unload Me End Sub الملف مرفق Abou_hassan.xlsm

الكود الصحيح Private Sub TextBox1_Change() Application.EnableEvents = False If ActiveSheet.FilterMode Then _ ActiveSheet.Range("A3").AutoFilter If ActiveSheet.TextBox1.Text <> "" Then Range("$A$3").AutoFilter field:=2, _ Criteria1:="=" & ActiveSheet.TextBox1.Text End If Application.EnableEvents = True End Sub

جرب هذا الكود (بعد تسمبة الشيت باسم Data) Option Explicit Sub Compaire_two_Col() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim D As Worksheet Dim Res_range As Range Dim LrA%, i%, x% Dim DIC As Object Set D = Sheets("Data") Set Res_range = D.Range("D1").CurrentRegion Set DIC = CreateObject("Scripting.Dictionary") LrA = D.Cells(Rows.Count, 1).End(3).Row If Res_range.Rows.Count > 1 Then _ Res_range.Offset(1).Resize(Res_range.Rows.Count).Clear With D For i = 2 To LrA Set Res_range = D.Range("J2:J" & LrA).Find(D.Cells(i, 2), lookat:=1) If Not Res_range Is Nothing Then x = Res_range.Row DIC(D.Cells(i, 2).Value) = D.Range("k" & x).Value End If Next If DIC.Count = 0 Then GoTo MY_End D.Range("E2").Resize(DIC.Count) = Application.Transpose(DIC.Items) .Range("F2").Resize(DIC.Count) = Application.Transpose(DIC.Keys) Set Res_range = D.Range("E1").CurrentRegion With Res_range .Sort Key1:=.Cells(1, 1), Header:=1 With .Offset(1).Resize(.Rows.Count - 1) .Borders.LineStyle = 1 .InsertIndent 1 .Font.Bold = True: .Font.Size = 14 .Interior.ColorIndex = 19 End With End With End With MY_End: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub File Include Abd_rahman.xlsm

المشكلة ان الأسماء في الفائمة الثانية ليست نفسها في القائمة الأولى مثلاُ الاسم (فريده طه اسماعيل داود) موجود في القائمة الاولى وغير موجود في الثانية اقترح ان ترفع ملفاً نموذجاً فيه بعض البيانات ( 10 اسطر من كل جدول لا اكثر)مع النتائج المتوقعة يدوياً (بدون فلتره اذا اردت) يمكن استبدال الأرقام في النموذج بارقام بسيطة 1و2و3 الخ... ولاسماء باسماء بسيطة مثلاً (A1,A2,A3.... ) لمعرفة المطلوب بالضبط بعد ذلك يمكن تعميم الكود على باقي الجدول

بعد اذن اخي الرائد لا لزوم للحلفات التكرارية لأكثر من 150 صف من البيانات (يمكن تجربة الكود على قليل من الصفوف 20 صف تقريباً لان الماكرو الذي يعمل على صف واحد يمكنه العمل على الوف الصفوف) 1-استبدال اسم الشيت الى Salim (لأني لا أفضّل التسمية باللغة العربية لحسن نسخ الكود ولصقه بدون مشاكل اللغة) 2- تنفيذ هذا الكود Option Explicit Sub Compaire_two_Col() Dim S As Worksheet Dim Res_range As Range Dim LrA% Set S = Sheets("Salim") LrA = S.Cells(Rows.Count, 1).End(3).Row Set Res_range = S.Range("D1").CurrentRegion If Res_range.Rows.Count > 1 Then _ Res_range.Offset(1).Resize(Res_range.Rows.Count).Clear S.Range("D2").Resize(LrA - 1, 2).Value = _ S.Range("A2").Resize(LrA - 1, 2).Value Set Res_range = S.Range("D1").CurrentRegion With Res_range .Sort Key1:=Res_range.Cells(1, 1), Header:=1 .RemoveDuplicates Columns:=1, Header:=xlYes End With Set Res_range = S.Range("D1").CurrentRegion With Res_range.Offset(1).Resize(Res_range.Rows.Count - 1) .Borders.LineStyle = 1 .InsertIndent 1 .Font.Bold = True .Interior.ColorIndex = 35 End With End Sub الملف مرفق Compair_data.xlsm

في الخلية K4 هذه المعادلة (وليس C4+E4+G4+I4) =SUM(C4,E4,G4,I4) واسحب نزولاً و كذلك في الخلية L4 =SUM(D4,F4,H4,J4) لأن الدلة SUM تعتبر النص(أو الفراغ) صفراً ولا تحتسبه

Try This Macro Sub Button02() ActiveSheet.Shapes.Range(Array("مستطيل 1")).Select If Selection.Text = "إخفاء الصفوف" Then Rows("5:20").EntireRow.Hidden = True With Selection .Font.ColorIndex = 2 .Text = "إظهار الصفوف" .ShapeRange.Fill.ForeColor.RGB = _ RGB(255, 0, 0) End With Else Rows("5:20").EntireRow.Hidden = False With Selection .Font.ColorIndex = 3 .Text = "إخفاء الصفوف" .ShapeRange.Fill.ForeColor.RGB = _ RGB(209, 255, 0) End With End If [A1].Select End Sub

جرب هذا الملف (الصفحة Target_sh ) الكود Option Explicit Sub Get_data() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim D As Worksheet, T As Worksheet Dim D_Rg As Range, T_rg As Range, Single_rg As Range Dim RoD%, RoT%, All_ro%, X%, y% Dim Nme$ Set D = Sheets("Data"): Set T = Sheets("Target_sh") Set D_Rg = D.Range("A4").CurrentRegion Set T_rg = T.Range("A3").CurrentRegion RoT = T_rg.Rows.Count If RoT > 1 Then _ T_rg.Offset(1).Resize(RoT - 1).Clear If D.FilterMode Then D_Rg.AutoFilter RoD = D_Rg.Rows.Count Set Single_rg = D_Rg.Offset(1).Resize(RoD - 1) Nme = T.Cells(3, "K") D_Rg.AutoFilter 4, Nme D_Rg.AutoFilter 3, "اجل" y = D_Rg.SpecialCells(12).Rows.Count If y > 0 Then Single_rg.Columns(2).SpecialCells(12).Copy T.Range("A4").PasteSpecial (12) Single_rg.Columns(8).SpecialCells(12).Copy T.Range("B4").PasteSpecial (12) End If D_Rg.AutoFilter D_Rg.AutoFilter 4, Nme D_Rg.AutoFilter 3, "نقدا" X = D_Rg.SpecialCells(12).Rows.Count If X = 0 Then Exit Sub Single_rg.Columns(2).SpecialCells(12).Copy T.Range("C4").PasteSpecial (12) Single_rg.Columns(8).SpecialCells(12).Copy T.Range("D4").PasteSpecial (12) All_ro = T.Range("A3").CurrentRegion.Rows.Count With T.Cells(All_ro + 3, 1) .Value = "المجموع:" .Offset(, 1) = Evaluate("=SUM(B4:B" & All_ro + 2 & ")") .Offset(, 2) = "المجموع:" .Offset(, 3) = Evaluate("=SUM(D4:D" & All_ro + 2 & ")") End With With T.Cells(4, 1).Resize(All_ro, 4) .InsertIndent 1: .Borders.LineStyle = 1 .Font.Size = 13: .Font.Bold = True .Interior.ColorIndex = 38 End With If D.FilterMode Then D_Rg.AutoFilter With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق Mabieat_Filter.xlsm

جرب هذا الملف Compaire.xls

جرب هذا الملف (تم تصميم اليوزر يحيث انه يمكنك التنقل داخل الصفحة حتى ولو كان اليوزر ظاهراً) لتعدبل البيانات: 1- اكتب الأسم الذي تريد تعديله (Salim) مثلاً 2- أملأ باقي البيانات 3- اضغط على زر تعديل (تظهر لك رسالة تسالك عن الاسم الجديد) مثلاً (Officena) 4-اضغط على Ok 5-اذا كان Salim موجوداً في العامود الثاني يقوم الماكرو بتغييره الى Officena مع بياناته الجديده My_data by_User form.xlsm

جرب هذا الكود Private Sub CommandButton1_Click() Sheets("انسولين الهيئة").Activate '============================================== Dim i As Integer, j As Integer, x, y lrow = Range("c" & Rows.Count).End(xlUp).Row + 1 If lrow < 5 Then lrow = 5 If lrow > 27 Then MsgBox "انتقل للبيان التالى": Exit Sub x = 4: y = 3 With Sheets("انسولين الهيئة") .Range("C5:J27").ClearContents For i = 1 To 144 .Cells(x, y) = Val(Me.Controls("TextBox" & i)) y = y + 1 If y = 11 Then y = 3: x = x + 1 Next End With End Sub

فقط بدّل الأسماء في الصفحات (داخل الكود) اي اجعل Targ هي ورقة القيود Source هي ورقة1

1-على حدود الجدول يجب ان تكون خلايا فارغة ( خلايا الاجمالي و ما الى ذلك يجب ان تبتعد عن الجدول ولو بصف واحد فارغ) الكود Option Explicit Sub copy_Range() Dim Soucre As Worksheet, Targ As Worksheet Dim Rg_s As Range, Dist As Range, Ro%, Last_ro% Set Soucre = Sheets("القيود") Set Targ = Sheets("ورقة1") Last_ro% = Targ.Cells(Rows.Count, 1).End(3).Row + 1 Set Rg_s = Soucre.Range("A5").CurrentRegion Ro = Rg_s.Rows.Count If Ro = 1 Then Exit Sub Set Rg_s = Rg_s.Offset(1).Resize(Ro - 1) Targ.Cells(Last_ro, 1).Resize(Rg_s.Rows.Count, Rg_s.Columns.Count).Value = _ Rg_s.Value Rg_s.ClearContents End Sub الملف مرفق 11_salim.xlsm

جرب هذا الملف (ربما كان المطلوب) Mabieat.xlsx

بعد تعديل البيانات ( اضافة حذف الخ..) اضغط على الزر لتحديث البيانات

جرب هذا الكود Option Explicit Sub GET_DATE_OFF() Dim Sh As Worksheet Dim Ro%, i%, My_rg As Range, Cel As Range Dim Dic As Object, arr Set Sh = Sheets("New Fomat Attendance") Set Dic = CreateObject("Scripting.Dictionary") Ro = Sh.Cells(Rows.Count, 1).End(3).Row If Ro < 5 Then Exit Sub Sh.Range("AI5").Resize(Ro).ClearContents For i = 5 To Ro Set My_rg = Sh.Range("D" & i).Resize(, 31) For Each Cel In My_rg If UCase(Cel) = UCase("OFF") Then Dic(Cells(4, Cel.Column).Value) = _ Dic(Cells(4, Cel.Column).Value) & "," End If Next Cel If Dic.Count Then Sh.Range("AI" & i) = Join(Dic.Keys, " , ") End If Dic.RemoveAll Next i End Sub الملف مرفق Abscent_Date.xlsm