سليم حاصبيا

1-تسمية اوراق العمل دائماً باللغة الاجنبية وأرفض من الآن وصاعداً اي ملف اسماء صفحاته باللغة العربية لما يسبب هذا الشيء من اضطراب في الكود اضافة الى صعوبة نسخة ولصقة لظهور احرف غريبة فية (عند البعض طبعاً) مع احترامي الشديد للغتنا العربية (لغة القرآن الكريم) لكنها لا تصلح لوضع اكواد الـــ VBA (نسبة الأحطاء 70% حسب الدّراسات) 2- للبحث عن اي فاتورة اكتب رقمها ثم اضغط Enter ( يتم تحديد ما تبحث عنه باللون الأصفر في الشبت) أو ( قم بتجديدها من الــ List Box ) 3- لحذف اي فاتورة اكتب رقمها ثم اضغط الزر حذف أو ( قم بتجديدها من الــ List Box ) ثم اضغط الزر حذف الاكواد المطلوبة Option Explicit Private sh As Worksheet Private Ro%, Col%, i% Private Arr_text(), Arr_Num() Private F As Range, itm, K% '++++++++++++++++++++++++++++++++++ Sub Debut() Set sh = Sheets("Main") Ro = sh.Cells(Rows.Count, 1).End(3).Row Col = 7 Arr_text = Array("Fat", "Dat", "Cahier", "Prod", _ "Qty", "Price", "Total") Arr_Num = Array(1, 2, 3, 4, 5, 6, 7) sh.Cells(1, 1).Resize(Ro, 7).Interior.ColorIndex = xlNone End Sub '+++++++++++++++++++++++++++++++++++++++ Private Sub Cmd_del_Click() Debut If Me.ListBox1.ListCount = 0 Or Me.Fnd = "" Then Exit Sub Set F = sh.Range("A1:A" & Ro).Find(Me.Fnd, Lookat:=1) If F Is Nothing Then Exit Sub K = F.Row If K <> 1 Then sh.Cells(K, 1).Resize(, 7).Delete UserForm_Initialize For Each itm In Arr_text Me.Controls(itm) = "" Next Fnd = "" End If End Sub '+++++++++++++++++++++++++++++++++++++++ Private Sub Fnd_AfterUpdate() Debut If Fnd = "" Then Exit Sub For Each itm In Arr_text Me.Controls(itm) = "" Next Set F = sh.Range("A1:A" & Ro).Find(Me.Fnd, Lookat:=1) If F Is Nothing Then MsgBox "This Item: " & """" & Me.Fnd & """" & Chr(10) & _ "Not Exists In Column (A)" Exit Sub End If K = F.Row For i = 0 To 6 Me.Controls(Arr_text(i)).Text = _ sh.Cells(K, Arr_Num(i)) Next sh.Cells(K, 1).Offset(1).Select sh.Cells(K, 1).Resize(, 7).Interior.ColorIndex = 6 End Sub '+++++++++++++++++++++++++++++++ Private Sub ListBox1_Click() Debut If ListBox1.ListCount = 0 Then Exit Sub If ListBox1.ListIndex = -1 Then Exit Sub Fnd = ListBox1.List(ListBox1.ListIndex, 0) Fnd_AfterUpdate End Sub '++++++++++++++++++++++++++++++++++++++++++ Private Sub UserForm_Initialize() Debut Me.ListBox1.RowSource = _ sh.Range("A2").Resize(Ro, Col).Address End Sub الملف مرفق My_ListBox.xlsm

جرب هذا الملف 1-تسمية اوراق العمل دائماً باللغة الاجنبية وأرفض من الآن وصاعداً اي ملف اسماء صفحاته باللغة العربية لما يسبب هذا الشيء من اضطراب في الكود اضافة الى صعوبة نسخة ولصقة لظهور احرف غريبة فية (عند البعض طبعاً) مع احترامي الشديد للغتنا العربية (لغة القرآن الكريم) لكنها لا تصلح لوضع اكواد الـــ VBA (نسبة الأحطاء 70% حسب الدّراسات) 2- من المفروض اضافة القليل من البيانات في الأوراق العمل ولا تتكل على من يريد المساعدة للقيام بذلك 3- تم وضع بعض المعادلات التي تساعد في ادراج النتائج (دون ظهور الأصفار) 4- الصف رقم 6 في الاوراق Bay و Inport يجب ان يبقى فارغاً الكود Option Explicit Sub From_Sheets_To_MaG() Dim Inp As Worksheet, Bay As Worksheet Dim Mag As Worksheet Dim Sh As Worksheet Dim L_Mag%, Max_ro%, col%, k%, ro% Dim Fnd As Range, Wat As Range Dim Old_val Set Inp = Sheets("Inport") Set Bay = Sheets("Bay") Set Mag = Sheets("Magazine") L_Mag = Mag.Cells(Rows.Count, 1).End(3).Row Set Fnd = Mag.Range("A1:A" & L_Mag) If Not (ActiveSheet.Name = "Inport" Or _ ActiveSheet.Name = "Bay") Then Exit Sub Set Sh = ActiveSheet Select Case Sh.Name Case "Bay": col = 6 Case "Inport": col = 5 Case Else: Exit Sub End Select Max_ro = Application.Max(Sh.Range("B6:B68")) + 6 For k = 7 To Max_ro Set Wat = Fnd.Find(Sh.Range("E" & k), lookat:=1) If Not Wat Is Nothing Then ro = Wat.Row Old_val = Val(Mag.Cells(ro, 3)) Mag.Cells(ro, 7) = Old_val Mag.Cells(ro, col) = Val(Sh.Range("H" & k)) Mag.Cells(ro, 3) = _ Old_val + Val(Mag.Cells(ro, 5)) - Val(Mag.Cells(ro, 6)) End If Next End Sub الملف مرفق Hasan_B.xlsm

تم التعديل كما تريد (مع تلوين الاجابة الصحيحة في حال اختيارها) Salim_Questions.xlsm

في سؤالك الاول كنت نريد ان تحذف منتج والان فاتورة حدد ما تريد اذ لا وقت لاضاعته

الملف كما يجب ان يكون Questions_perfect.xlsm

مع هذه الكمية الهائلة من الخلايا المدمجة لا يمكن لاي كود ان يعمل بسهولة فما الغاية من دمج الاعمدة من H الى AX (27 عامود) مثلا من اجل كتابة 4 كلمات "بماذا يكنى الهدهد والثعلب" كما في الصورة 1 اضافة الى دمح الخلايا في اماكن اخرى مثلاً من E12 الى K13 (صفين من الخلايا و 7 أعمدة ) اجل كتابة "الاجابة رقم 1" يجب ان يكون الملف كما في الصفحة Salim الصورة رقم 2 ( الخلايا من I5 الى L5 في "الصفحة Salim" ليست مدمحة حتى وان كانت تبدو كذلك) الملف كما يجب ان يكون مرفق Questions.xlsm

اذا كان تم تم المطلوب اضغط افضل اجابة لاغلاقه ولا تنس الضغط على اعجاب ايضاً

تفضل با ضديقي TQTHAMI و عيد سعيد TQTHAMI.xlsm

اولاً - من يتظر الى الصورة يعزف عن المساعدة لكثرة الألوان المزركشة في الملف التي تبهر النظر من جهة و تزيد من حجمه دون جدوى من جهة اخرى ثانيا- الضورة لا تعطي نتيجة للمساعدة حيث لا امكانية من كتابة اي معادلة او كود على الصورة لذا ازل الالوان وارفع الملف نفسه و عندما تحصل على الاجالة لوّن كما نريد

الكود (اذا كانت البيانات كبيرة جداً 100000 ضف ربما يأحذ وقتاً ليس بالقليل) Option Explicit Sub AL_in_One() Dim A As Worksheet, R As Worksheet Dim Rg_To_Copy As Range, F_rg As Range Dim Max_ro%, Adr1%, Adr2% Dim Boldate As Boolean, BolF3 As Boolean Dim BolF4 As Boolean Set A = Sheets("ALL") Set R = Sheets("Repport") R.Range("A8").CurrentRegion.Clear Max_ro = A.Cells(Rows.Count, 1).End(3).Row Set F_rg = A.Range("B2").Resize(Max_ro).Find(R.Range("C3"), lookat:=1) If Not F_rg Is Nothing Then Adr1 = F_rg.Row: Adr2 = Adr1 Do Boldate = IsDate(A.Range("A" & Adr2)) BolF3 = Int(A.Range("A" & Adr2)) >= R.Range("F3") BolF4 = Int(A.Range("A" & Adr2)) <= R.Range("F4") If Boldate * BolF3 * BolF4 <> 0 Then If Rg_To_Copy Is Nothing Then Set Rg_To_Copy = A.Range("A" & Adr2).Resize(, 5) Else Set Rg_To_Copy = Union(Rg_To_Copy, A.Range("A" & Adr2).Resize(, 5)) End If 'Rg_To_Copy End If 'Boolean Set F_rg = A.Range("B2").Resize(Max_ro).FindNext(F_rg) Adr2 = F_rg.Row If Adr2 = Adr1 Then Exit Do Loop End If 'F_rg Is Nothing If Not Rg_To_Copy Is Nothing Then Rg_To_Copy.Copy R.Range("A8").PasteSpecial End If Application.CutCopyMode = False R.Activate: Range("C3").Select End Sub الملف مرفق Badawi_1.xlsm

جرب هذا الملف 1- اكتب ما تريد في الــ TextBox1 واضغط Enter 2 -لحذف صنف قم بتضليله في الــ ListBox1 واضغط الزر المناسب الكود Private Sub DeL_It_Click() Dim FND As Range Dim lr%, Ro1%, Ro2%, i% Dim t% Dim my_rg As Range Dim Sh As Worksheet t = Me.ListBox1.ListIndex If t <= 0 Then Exit Sub Set Sh = Sheets("ارشيف العمليات") lr = Sh.Cells(Rows.Count, 1).End(3).Row With Me.ListBox1 Set FND = Sh.Range("D1:D" & lr).Find(Me.ListBox1.List(t, 3), lookat:=1) If FND Is Nothing Then Exit Sub Ro1 = FND.Row: Ro2 = Ro1 End With Do If my_rg Is Nothing Then Set my_rg = Sh.Range("A" & Ro2).Resize(, 7) Else Set my_rg = Union(my_rg, Sh.Range("A" & Ro2).Resize(, 7)) End If Set FND = Sh.Range("D1:D" & lr).FindNext(FND) Ro2 = FND.Row If Ro1 = Ro2 Then Exit Do Loop my_rg.Delete xlUp lr = Sh.Cells(Rows.Count, 1).End(3).Row Me.ListBox1.Clear Me.ListBox1.RowSource = Range("A2:G" & lr).Address End Sub '+++++++++++++++++++++++++++++++++++++++ Private Sub TextBox1_AfterUpdate() Dim FND As Range Dim lr%, Ro1%, Ro2%, i% Dim Sh As Worksheet Set Sh = Sheets("ارشيف العمليات") lr = Sh.Cells(Rows.Count, 1).End(3).Row Me.ListBox1.Clear Set FND = Sh.Range("A1:A" & lr).Find(Me.TextBox1, lookat:=1) If FND Is Nothing Then Exit Sub Ro1 = FND.Row: Ro2 = Ro1 Do With Me.ListBox1 .AddItem For i = 0 To .ColumnCount - 1 .List(.ListCount - 1, i) = _ Sh.Cells(Ro2, 1).Offset(, i).Text Next End With Set FND = Sh.Range("A1:A" & lr).FindNext(FND) Ro2 = FND.Row If Ro1 = Ro2 Then Exit Do Loop End Sub الملف مرفق Hisham_Jamal.xlsm

لا حاجة للكود في هذا الملف تكفي المعادلات Badawi.xlsx

سبب المشاكل كلها هي الخلايا المدمحة

اظن انه ليس هناك حاجة لاستعمال البوزرفورم (فقط اضغط الزر GO في الصفحة Target ) الكود Option Explicit Sub AL_in_One() Dim T As Worksheet Dim Sh As Worksheet Dim arr(), itm Dim Max_ro%, k% Dim Adr1%, Adr2% Dim F_rg As Range arr = Array("First", "Second", "Third") Set T = Sheets("Target") T.Range("A1").CurrentRegion.Offset(1).Clear k = 2 For Each itm In arr Set Sh = Sheets(itm) Max_ro = Sh.Cells(Rows.Count, 2).End(3).Row Set F_rg = Sh.Range("o2").Resize(Max_ro).Find("*", lookat:=1) If Not F_rg Is Nothing Then Adr1 = F_rg.Row: Adr2 = Adr1 Do T.Range("B" & k).Resize(, 21).Value = _ Sh.Range("B" & Adr2).Resize(, 21).Value T.Range("W" & k) = Sh.Name & ": (" & Adr2 & ")" T.Range("A" & k) = k - 1 k = k + 1 Set F_rg = Sh.Range("o2").Resize(Max_ro).FindNext(F_rg) Adr2 = F_rg.Row If Adr2 = Adr1 Then Exit Do Loop End If Next itm If k > 2 Then With T.Range("A2").Resize(k - 2, 23) With .Font .Size = 14: .Bold = True End With .InsertIndent 1 .Borders.LineStyle = 1 .Interior.ColorIndex = 20 End With End If End Sub Fares_hasan.xlsm

جرب هذا الملف 1-القائمة المنسدلة في الخلية K4 دينامبكية اي انها تدرج كل الاسماء من D7 الى D50 دون تكرار 2- المعادلات محمية لعدم الكتابة عليها عن طريق الحطأ Sasa fathi.xlsx

سبب المشاكل كلها هي الخلايا المدمحة (تم ازالة ما يعيق منها عمل الماكرو) Hid_col_1.xlsm

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

حرب هذا الكود اضفط الزر المناسب Option Explicit Sub Show_Only() Dim Rg As Range Dim col% Range("H1").Resize(, 72).EntireColumn.Hidden = True Set Rg = Range("H3").Resize(, 72).Find(Range("A1"), lookat:=1) If Rg Is Nothing Or Range("A1") = "" Then show_all Exit Sub End If col = Rg.Column Cells(4, col).Resize(, 2).EntireColumn.Hidden = False End Sub '+++++++++++++++++++++++++++++++ Sub show_all() Range("H1").Resize(, 72).EntireColumn.Hidden = False End Sub yasse.w.2010.xlsm

Try this code Sub fil_empty() Range("A1").CurrentRegion.SpecialCells(4) = "Abscent" End Sub

البداية فقط لاول نطاقين من AE7 الى AE25 ثم تتابع الى باقي النطاقات كل نطاق حسب المعادلة المناسبة Sub From_Tornula_To_Vba() Const Ro = 23 With Sheets("Sheet1") .Range("AE7:AE" & Ro).Formula = _ "=IF(AND(ISNUMBER(I7),ISNUMBER(K7)),G7,"""")" .Range("AF7:AF" & Ro).Formula = _ "=IF(AND(ISNUMBER(I7),ISNUMBER(K7)),M7,"""")" .Range("AE7:AF" & Ro).Value = _ .Range("AE7:AF" & Ro).Value End With ''''''وهكذا الى نهاية النطاق End Sub من اجل الـــ SUMPRODUCT هذا الكود Option Explicit Sub From_SUMPRODUCT_To_Vba() Dim My_formula$, i As Byte, arr() My_formula = "=SUMPRODUCT(($BN$7:$BN$23=My_Cel)*($BP$7:$BP$23))+" My_formula = My_formula & "SUMPRODUCT(($BQ$7:$BQ$23=My_Cel)*($BO$7:$BO$23))" arr = Array("CA9", "CA13", "CA17") For i = LBound(arr) To UBound(arr) With Sheets("Sheet1").Range("CC9").Offset(4 * i) .Formula = _ Replace(My_formula, "My_Cel", arr(i)) .Value = .Value End With Next i End Sub

كان من المفروض تحميل ملف مع شرح المطلوب بدقة (كما اقترح الاستاذ هاني محمد) ولا لزوم لتضييع اكثر من ساعة من الوقت على كتابة معادلات وفي الأخير تظهر انها ليست المطلوبة لذا كنت أريد الاعتذار عن المتابعة بهذا الملف لكن حيث انها المرة الاولى لا بد من الاستجابة الكود Option Explicit Function Salim_Letter(rg As Range) Dim dic As Object, i Dim ST, Mot$ Mot = Replace(rg.Value, " ", "") Set dic = CreateObject("Scripting.Dictionary") For i = 1 To Len(Mot) If Not dic.Exists(Mid(Mot, i, 1)) Then dic(Mid(Mot, i, 1)) = dic.Count End If Next i If dic.Count Then ST = Join(dic.keys, " ") Else ST = vbNullString End If Salim_Letter = ST End Function جرب هذا الملف Remove_duplicate_letters.xlsm

حيث انك لم ترفع ملف للمعاينة اليك هذا النموذج مع صورو عن التنتيجة 1-الاسماء في العامود B 2- عدد الحرف المطلوبة في العامود A 3- المعادلات في النطاق من C2 الىAF26 المعادلات في العامود A =IF($B2="","",SUM(IF(FREQUENCY(MATCH(MID(TRIM(SUBSTITUTE($B2," ","")),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ",""))))),1),MID(TRIM(SUBSTITUTE($B2," ","")),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ",""))))),1),0),MATCH(MID(TRIM(SUBSTITUTE($B2," ","")),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ",""))))),1),MID(TRIM(SUBSTITUTE($B2," ","")),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ",""))))),1),0)),1,0))) في النطاق من C2 الى AF26 =IF(OR(COLUMNS($A$2:A2)>$A2,$A2=""),"",MID(SUBSTITUTE(TRIM($B2)," ",""),SMALL(IF(FREQUENCY(MATCH(MID(TRIM(SUBSTITUTE($B2," ","")),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ",""))))),1),MID(TRIM(SUBSTITUTE($B2," ","")),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ",""))))),1),0),MATCH(MID(TRIM(SUBSTITUTE($B2," ","")),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ",""))))),1),MID(TRIM(SUBSTITUTE($B2," ","")),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ",""))))),1),0)),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ","")))))),COLUMNS($A$2:A2)),1)) صورة عن الملف الملف مرفق KARIM.xlsx

جرب هذه المعادلة في الخلية H9 واسحب نزولاً =IFERROR(SUM(OFFSET(INDEX($A$2:$A$37,MATCH($J9,$A$2:$A$37,0)):INDEX($A$2:$A$37,MATCH($I9,$A$2:$A$37,0)),,1)),"") الملف مرفق Hafez.xlsx

المطلوب غير واضح عن ماذا تريد البحث؟؟؟ و ما هي النتائج المطلوبة؟؟؟

اردت الاعتذار عن المتابعة بهذا الملف ااسبب التالي في اول مشاركة لك من خلال العبارة التي كتبتها: *** فإذا كان الموظف لديه بند مثلا راتب اساسي ، بدل سكن ، اجمالي الاستحقاق ( هذه ثلاثةبنود ) فإن الموظف سينقل ويكرر ثلاث مرات في الصفوف، بحيث يكون مقابل كل اسم لهذا الموظف البند والمبلغ الخاص به. والان تريد *** اسماء الموظفين في الصفوف لا يمكن تتكرر. بمعنى لا يمكن ان يتكرر اسم الموظف في اكثر من صف لكن بما هي المرة الأولى تم التعديل على الماكرو لبعمل كما تريد الماكرو الجديد (العمل في صفحة Salim ) Sub Enplyee_Data() Dim Target_sheet As Worksheet Dim SA As Worksheet Dim RO%, ROS%, i%, n% Dim How_many%, m%, t%, x% Dim Data As Range Dim Dic As Object, Ky Dim arr_Band(), arr_Num() Application.ScreenUpdating = False Set Target_sheet = Sheets("Salim") Set SA = Sheets("Salary") RO = Target_sheet.Cells(Rows.Count, 1).End(3).Row If RO > 2 Then Target_sheet.Range("A3:H" & RO + 2).Clear End If ROS = SA.Cells(Rows.Count, 1).End(3).Row Set Dic = CreateObject("Scripting.Dictionary") For i = 4 To ROS If SA.Cells(i, 6) <> "" Then Dic(SA.Cells(i, 6).Value) = "" End If Next i If Dic.Count Then m = 3 For Each Ky In Dic.keys n = Application.Match(Ky, SA.Range("f4:f" & ROS), 0) + 3 How_many = Application.CountA(SA.Range("H" & n).Resize(, 60)) Target_sheet.Range("A" & m).Resize(How_many, 6).Value = _ SA.Range("a" & n).Resize(, 6).Value m = m + How_many + 1 Next Ky For x = 3 To m - 2 If Application.CountIf(Target_sheet.Range("F3:F" & x), Target_sheet.Range("F" & x)) = 1 Then n = Application.Match(Target_sheet.Range("F" & x), SA.Range("f4:f" & ROS), 0) + 3 For y = 8 To 67 If SA.Cells(n, y) <> "" Then ReDim Preserve arr_Band(t) arr_Band(t) = SA.Cells(3, y) ReDim Preserve arr_Num(t) arr_Num(t) = SA.Cells(n, y) t = t + 1 End If Next y End If '<> "" If t > 0 Then Target_sheet.Range("G" & x).Resize(t) = _ Application.Transpose(arr_Band) Target_sheet.Range("H" & x).Resize(t) = _ Application.Transpose(arr_Num) End If 't>0 t = 0: Erase arr_Num: Erase arr_Num Next x End If RO = Target_sheet.Cells(Rows.Count, 1).End(3).Row t = 3 If RO > 2 Then For n = 3 To RO + 1 If Target_sheet.Cells(n, 1) = "" Then Target_sheet.Cells(n, "F") = "Sum Of " & Target_sheet.Cells(n - 1, "F") Target_sheet.Cells(n, "F").Resize(, 2).Merge Target_sheet.Cells(n, "H").Formula = _ "=SUM(H" & t & ":H" & n - 1 & ")" t = n + 1 End If Next Target_sheet.Cells(n, "F") = "Sum Of All " Target_sheet.Cells(n, "H").Formula = _ "=SUM(H3:H" & n - 1 & ")/2" Target_sheet.Cells(n, "F").Resize(, 2).Merge With Target_sheet.Range("A3:H" & n) .Font.Size = 14 .Font.Bold = True .Borders.LineStyle = 1 .InsertIndent 1 .Interior.ColorIndex = 35 .Value = .Value .Columns(8).NumberFormat = "#,##0" End With For n = 3 To RO + 1 If Target_sheet.Cells(n, 1) = "" Then Target_sheet.Cells(n, 1).Resize(, 8). _ Interior.ColorIndex = 28 End If Next Target_sheet.Cells(n, 1).Resize(, 8). _ Interior.ColorIndex = 40 End If Application.ScreenUpdating = True End Sub '++++++++++++++++++++++++++++++++ الملف مرفق RAWATEB_ADVANCED.xlsm