نجوم المشاركات

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاخوة الكرام اليك اخي حل اخر استدعاء الراسبين الى ورقة دور ثاني في حالة الوجود المسبق لرؤوس عناوين الاعمدة Sub CopyData1() Dim x, y(), i&, lr&, a&, r& Set sh1 = ThisWorkbook.Worksheets("شيت") Set sh2 = ThisWorkbook.Worksheets("دور ثان") lr = sh1.Range("a" & Rows.Count).End(xlUp).Row lr2 = sh2.Cells(sh2.Rows.Count, "a").End(xlUp).Offset(1).Row Application.ScreenUpdating = False x = sh1.Range("A7:AN" & lr) For i = 1 To UBound(x, 1) If x(i, 40) = "دور ثاني" Then r = r + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To r) For a = 1 To UBound(x, 2) y(a, r) = x(i, a) Next End If Next With sh2 sh2.Range("A7:AN" & lr2).ClearContents sh2.[A7].Resize(r, UBound(y, 1)) = Application.Transpose(y) F = sh2.Range("A65500").End(xlUp).Row G = sh2.Cells(7, Columns.Count).End(xlToLeft).Column sh2.Range("A7:AN" & lr2).Borders.LineStyle = xlNone sh2.Range(Cells(7, 1), sh2.Cells(F, G)).Borders.Weight = xlThin End With Application.ScreenUpdating = True End Sub ولنسخ البيانات الى ورقة لا تتضمن رؤوس اعمدة يمكنك استخدام الكود التالي Sub CopyData2() Dim rAlt As Range Dim x, y(), i&, lr&, a&, r&, n& Set sh1 = ThisWorkbook.Worksheets("شيت") Set sh2 = ThisWorkbook.Worksheets("Sheet3") lr = sh1.Range("a" & Rows.Count).End(xlUp).Row lr2 = sh2.Cells(sh2.Rows.Count, "a").End(xlUp).Offset(1).Row Application.ScreenUpdating = False Set rAlt = sh1.Range("A1:AN6") For n = 1 To 40 Set rAlt = Union(rAlt, Intersect(rAlt.EntireRow, Columns(n))) Next n rAlt.COPY Destination:=sh2.Range("A1") x = sh1.Range("A7:AN" & lr) For i = 1 To UBound(x, 1) If x(i, 40) = "دور ثاني" Then r = r + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To r) For a = 1 To UBound(x, 2) y(a, r) = x(i, a) Next End If Next sh2.Activate [A7].Resize(r, UBound(y, 1)) = Application.Transpose(y) F = sh2.Range("A65500").End(xlUp).Row G = sh2.Cells(7, Columns.Count).End(xlToLeft).Column Range("A7:an100").Borders.LineStyle = xlNone Range(Cells(7, 1), Cells(F, G)).Borders.Weight = xlThin Columns("A:AN").EntireColumn.AutoFit Columns("H:AM").EntireColumn.Hidden = True Application.ScreenUpdating = True End Sub V1 خالد.xlsb

السلام عليكم العمل بسيط ... وتعليمات ا/ lionheart سهلة تفضل اخي ... نسخة من اضافة صورة شعار لجميع الشهائد.xlsm

In worksheet module Private Sub Worksheet_Change(ByVal Target As Range) Dim v If Target.Address = "$B$2" Then v = Target.Value Rows("15:200").Hidden = False If v = 0 Then Rows("15:200").Hidden = True ElseIf v = Range("N67").Value Then Rows("51:200").Hidden = True ElseIf v = Range("N68").Value Then Rows("15:50").Hidden = True Rows("71:200").Hidden = True ElseIf v = Range("N69").Value Then Rows("15:70").Hidden = True Rows("151:200").Hidden = True ElseIf v = Range("N70").Value Then Rows("15:150").Hidden = True End If End If End Sub

Move the school logo as shown and rename it [School_Logo] 01 Modify the following parts in the code Sub kh_AutoFill(R As Integer) Dim SourceRange As Range, fillRange As Range, RR As Long, i As Long, j As Long RR = (R * CountRow) With MySheet Set SourceRange = .Rows(FirstRow).Resize(CountRow) Set fillRange = .Rows(FirstRow).Resize(RR) SourceRange.AutoFill fillRange, xlFillDefault For i = FirstRow To (FirstRow + RR - 1) Step CountRow j = (i - FirstRow) / CountRow + 1 .Shapes("School_Logo").Copy .Cells(i + 1, "O").PasteSpecial xlPasteAll .Shapes(.Shapes.Count).Name = "LH_Logo_" & j Next i .PageSetup.PrintArea = .Range("B" & FirstRow).Resize(RR, CountColumn).Address End With End Sub Also modify the following Sub Kh_Picture_Delete(MySh As Worksheet) On Error Resume Next Dim shp As Shape For Each shp In MySh.Shapes If shp.Name Like "KHK_*" Or shp.Name Like "LH_Logo_*" Then shp.Delete End If Next shp On Error GoTo 0 End Sub

In standard module Function ConvertToArabicNumber(ByVal num As String) As String Dim s As String, d As String, i As Long For i = 1 To Len(num) d = Mid(num, i, 1) s = s & ChrW(&H660 + Val(d)) Next i ConvertToArabicNumber = s End Function In the userform module modify the following procedure Private Sub ListBox1_Click() For i = 0 To ListBox1.ListCount If ListBox1.Selected(i) = True Then For j = 1 To 61 Controls("TextBox" & j).Text = ConvertToArabicNumber(Cells(ListBox1.List(i, 1), j)) Next j r = ListBox1.List(i, 1) Exit For End If Next i End Sub

Sub Uniques() Dim Rng As Range, derlig& Dim WSDest As Worksheet: Set WSDest = Sheets("Sheet1") derlig = WSDest.Range("a" & Rows.Count).End(xlUp).Row + 1 WSDest.Range("c2:c" & derlig).ClearContents For Each Rng In Range("A2:A" & derlig) If WorksheetFunction.CountIf(Range("B2:B" & derlig), Rng) = 0 Then Range("C" & Rows.Count).End(xlUp).Offset(1) = Rng End If Next End Sub TEST_Uniques.xlsm

تفضل يا سيدي 🙂 النموذج والاستعلام هكذا : . وزر "عرض التقرير" يحتوي على هذا الكود في حدث النقر: Private Sub cmd_Preview_Click() Dim varItem As Variant Dim myWhere As String myWhere = "" ' Loop through the selected items in the ListBox For Each varItem In Me.lst_XX.ItemsSelected ' Add each selected item to the string myWhere = myWhere & "'" & Me.lst_XX.ItemData(varItem) & "', " Next varItem ' Remove the trailing comma and space from the string myWhere = Left(myWhere, Len(myWhere) - 2) 'هذه الفقرة الاخيرة بتعطينا المواد التي تم اختيارها بهذا التنسيق: 'الإقتصادية', 'الادارية', 'التربوية' DoCmd.OpenReport "qry_Section_Gender_Count", acViewPreview, , "[Section] in (" & myWhere & ")" 'والامر النهائي يصبح هكذا: 'DoCmd.OpenReport "qry_Section_Gender_Count", acViewPreview, , "[Section] in ('الإقتصادية', 'الادارية', 'التربوية')" End Sub . والنتيجة: جعفر 1563.baseNN.accdb.zip

السلام عليكم الاخوة الكرام الف الف شكر لحضراتكم جميعا ان شاء الله هبداء و لو فى اي حاجة وقفت معايا هكتب على الجروب المحترم الرائع كل سنة و حضراتكم بالف خير

و عليكم السلام ورحمة الله وبركاته ما الذي حاولت البحث عنه ولم يؤت ثماره؟

Wait for someone to attach the file for you. I don't attach files You have to apply the steps by yourself. Sorry for that

تفضل اخي ربما هدا ما تقصده Sub ChangeColor() Dim lrow& Dim WS1 As Worksheet: Set WS1 = Sheets("Raw Data") Dim WS2 As Worksheet: Set WS2 = Sheets("Do Not Include") lrow = WS1.Range("B" & Rows.Count).End(xlUp).Row Rng = WorksheetFunction.CountA(WS1.Range("A4", WS1.Range("A4").End(xlDown))) + 3 Application.ScreenUpdating = False WS1.Activate WS1.Range(Cells(5, 2), Cells(Rng, 2)).Interior.ColorIndex = 0 If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then ActiveSheet.ShowAllData End If Set r = WS1.Range("B5:B" & lrow) For Each cell In r If cell.Value = WS2.Range("A1") Then cell.Interior.Color = RGB(34, 153, 166) cell.Select End If Next Application.ScreenUpdating = True End Sub test 7.xlsm

وعليكم السلام-تفضل بما انك لم تقم برفع ملف للمطلوب ..فهذا الفيديو به طلبك

المفروض انك لا تقوم برفع الملف وطلب المساعدة حتى تتاكد من الانتهاء من تصميمه تفاديا لاهدار الوقت والاشتغال على الملف اكثر من مرة Sub CopyData() Dim x, y(), i&, lr&, a&, r& Set sh1 = ThisWorkbook.Worksheets("شيت") Set sh2 = ThisWorkbook.Worksheets("دور ثان") lr = sh1.Range("a" & Rows.Count).End(xlUp).Row lr2 = sh2.Cells(sh2.Rows.Count, "a").End(xlUp).Offset(1).Row Application.ScreenUpdating = False ' نطاق البيانات x = sh1.Range("A7:H" & lr) For i = 1 To UBound(x, 1) 'H' الشرط في العمود If x(i, 8) = "دور ثاني" Then r = r + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To r) For a = 1 To UBound(x, 2) y(a, r) = x(i, a) Next End If Next With sh2 ' افراغ البيانات السابقة sh2.Range("A7:H" & lr2).ClearContents ' لصق البيانات sh2.[A7].Resize(r, UBound(y, 1)) = Application.Transpose(y) 'تسطير الجدول F = sh2.Range("A65500").End(xlUp).Row G = sh2.Cells(7, Columns.Count).End(xlToLeft).Column sh2.Range("A7:H" & lr2).Borders.LineStyle = xlNone sh2.Range(Cells(7, 1), sh2.Cells(F, G)).Borders.Weight = xlThin End With Application.ScreenUpdating = True End Sub ولنسخ البيانات الى ورقة لا تتضمن رؤوس اعمدة هدا مثال لاستدعاء الناجحين Sub CopyData2() Dim rAlt As Range Dim x, y(), i&, lr&, a&, r&, n& Set sh1 = ThisWorkbook.Worksheets("شيت") Set sh2 = ThisWorkbook.Worksheets("ناجح") lr = sh1.Range("a" & Rows.Count).End(xlUp).Row lr2 = sh2.Cells(sh2.Rows.Count, "a").End(xlUp).Offset(1).Row Application.ScreenUpdating = False sh1.Activate 'نسخ رؤؤوس الاعمدة Set rAlt = sh1.Range("A1:H6") For n = 1 To 8 Set rAlt = Union(rAlt, Intersect(rAlt.EntireRow, Columns(n))) Next n 'لصق rAlt.COPY Destination:=sh2.Range("A1") x = sh1.Range("A7:H" & lr) For i = 1 To UBound(x, 1) ' المعيار If x(i, 8) = "ناجح" Then r = r + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To r) For a = 1 To UBound(x, 2) y(a, r) = x(i, a) Next End If Next sh2.Activate 'لصق في الصف السابع [A7].Resize(r, UBound(y, 1)) = Application.Transpose(y) ' تسطير حدود البيانات F = sh2.Range("A65500").End(xlUp).Row G = sh2.Cells(7, Columns.Count).End(xlToLeft).Column Range("A7:H1000").Borders.LineStyle = xlNone Range(Cells(7, 1), Cells(F, G)).Borders.Weight = xlThin ' تنسيق الاعمدة Columns("A:H").EntireColumn.AutoFit Application.ScreenUpdating = True End Sub v2 خالد.xlsb

شكرا جزيلا استاذنا الكبير محمد وأنا آسف إني اتأخرت في الرد لأني كنت مسافر

Another solution Format the numbers on the worksheet with the following custom format [$-,201]0 then modify this line Controls("TextBox" & j).Text = Cells(ListBox1.List(i, 1), j).Text

نعم يمكن ذلك ولكن أرى أن تغير طريقة عملك لتكون أكثر احترافية فيكون هناك جدول بيانات العملاء يشمل اسم العميل وعنوانه ... الخ وجدول آخر بيانات الفواتير ويشمل اسم العميل ورقم الفاتورة وتاريخها وهل هي مستحقة الدفع وتاريخ السداد ... الخ السؤال.xlsx 22.xlsx

وعليكم السلام ورحمه الله يمكنك استخدام التالي لتحويل أي نص من الأحرف (الإنجليزية على سبيل المثال) إلى أحرف عربية: Function ConvertNumbersToArabic(ByVal strInput As String) As String Dim ch As String Dim Result As String Dim i As Integer Result = "" For i = 1 To Len(strInput) ch = Mid$(strInput, i, 1) Select Case ch Case "0" Result = Result & "٠" Case "1" Result = Result & "١" Case "2" Result = Result & "٢" Case "3" Result = Result & "٣" Case "4" Result = Result & "٤" Case "5" Result = Result & "٥" Case "6" Result = Result & "٦" Case "7" Result = Result & "٧" Case "8" Result = Result & "٨" Case "9" Result = Result & "٩" Case Else Result = Result & ch End Select Next i ConvertNumbersToArabic = Result End Function يمكنك استدعاء هذه الدالة على سبيل المثال على النحو التالي TextBox1.Value = ConvertNumbersToArabic(TextBox1.Value)

وعليكم السلام ورحمه وبركاته جرب الكود التالي عدله حسب ما تريد Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$B$2" And Target.Value = "0" Then Rows("15:200").EntireRow.Hidden = True End If End Sub

السلام عليكم المنتدى مليء بالكنوز ... والمشكله فعلا في الاعضاء _ وانا منهم _ لعدم استخدام خاصية البحث في المنتدى لكني حاولت اكثر من مرة استخدام هذه الخاصية ولم اصل لشيء فارجو من القائمين على المنتدى ... تثبيت موضوع لكيفية البحث وطرقه المختلفة هل بالـ (كلمة _ جملة _ تاريخ ) حتى نصل الى مانريد ...

أتمنى أن أكون فهمت المطلوب المعادلة المستخدمة =IFERROR(INDEX(n_f;AGGREGATE(15;6;(ROW($A$1:$A$30))/((name1=$A2)*(date1>=$N$2)*(date1<=$O$2));COLUMN(A1));1);"") السؤال.xlsx 22.xlsx

جزاك الله خيرا

السلام عليكم ورحمة الله وبركاته،،، حاولت أخي الكريم أبو عاصم نسخ الماكرو ووضعه في المكان المخصص له، تظهر لي رسالة خطأ، علماً أنني حددت الشطر الثاني من الأبيات الشعرية، وبعد تنفيذ الماكرو تظهر المشكلة. لاطلاعكم لطفاً

بارك الله فيك أخي الفاضل أبو عاصم المصري، ما شاء الله، مُبدع الله يعطيك العافية شاكر لك جهودك الطيبة

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub test() Dim lR&, lRow& Dim Y As Range, R As Range Dim wsCopy As Worksheet: Set wsCopy = Sheets("Sheet1") Dim wsDest As Worksheet: Set wsDest = Sheets("Sheet2") lRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row Application.ScreenUpdating = False wsDest.Range("B10:K" & lRow).ClearContents With wsCopy lR = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row .Range(.Cells(22, "B"), .Cells(lR, "E")).Copy wsDest.Cells(10, "B") End With With wsDest For Each Y In .Range("C10:C" & .Cells(Application.Rows.Count, 3).End(xlUp).Row) Set R = wsCopy.Columns(3).Find(Y.Value, , xlValues, xlPart) If Not R Is Nothing And R.Offset(0, 4).Value = "غ" Or R.Offset(0, 4).Value = "دون المستوى" Then Y.Offset(0, 3).Value = "X" If Not R Is Nothing And R.Offset(0, 6).Value = "غ" Or R.Offset(0, 6).Value = "دون المستوى" Then Y.Offset(0, 4).Value = "X" If Not R Is Nothing And R.Offset(0, 8).Value = "غ" Or R.Offset(0, 8).Value = "دون المستوى" Then Y.Offset(0, 5).Value = "X" If Not R Is Nothing And R.Offset(0, 10).Value = "غ" Or R.Offset(0, 10).Value = "دون المستوى" Then Y.Offset(0, 6).Value = "X" If Not R Is Nothing And R.Offset(0, 12).Value = "غ" Or R.Offset(0, 12).Value = "دون المستوى" Then Y.Offset(0, 7).Value = "X" If Not R Is Nothing And R.Offset(0, 14).Value = "غ" Or R.Offset(0, 14).Value = "دون المستوى" Then Y.Offset(0, 8).Value = "X" Next Y End With Application.ScreenUpdating = True End Sub OSAMA_V1.xlsm

أسف تاخرت بالرد لانشغالي مشاركة مع الاساتذة والحبايب بالتوفيق kids.accdb

نعم .. طريقة البحث ممتازة، لا سيما وأنه يبحث داخل الـ (comboBox) نفسه وليس عبر مربع نص خارجي، ثم يخرج النتائج مع التغيير أثناء الكتابة وليس بعد التحديث أو عند الخروج أما بخصوص التنقل بين النتائج، فقد تمكنت بفضل الله من حل هذه المشكلة بوضع هذا الكود في حدث (عند مفتاح للأسفل) If KeyCode = 40 And Shift = 0 Or KeyCode = 38 And Shift = 0 Then G = 1 End If مع إضافة بسيطة في أول كود البحث كما في الملف المرفق فأصبح يتنقل بين النتائج باستخدام مفتاحي: للأعلى وللأسفل فأرجو أن يكون تصرفي هو الحل الصحيح ولدي ملاحظة أخرى بخصوص هذا الكود: فهو يبحث عن الحروف حتى لو كانت متتالية في أكثر من كلمة، وبالنسبة لي فالمطلوب البحث عن الحروف متتابعة أو متلاصقة في نفس الكلمة يعني عند طلب البحث عن (زج) تخرج النتائج بهذا الشكل والنتيجة الأخيرة غير مطلوبة بالنسبة لي، ولكنه يبحث عن الحروف المدخلة حتى إذا لم تكن متتابعة في نفس الكلمة، لذلك أخرج النتيجة الأخيرة لأنه وجد حرف (ز) في كلمة (زاهد) ثم وجد حرف (ج) في كلمة (للتجارة) وهذه الطريقة في البحث قد تناسب غيري بل قد تكون بغيته المنشودة، لكن بالنسبة لي فالنتيجة المطلوبة هي وتمكنت بفضل الله من الوصول إليها بعد عدة تجارب ومحاولات في حذف بعض أسطر الكود .. حذفتها من باب التجربة لأني بصراحة لا أعلم ماذا تعني ؟؟ 😅 فلست من أهل الاختصاص وإنما من أهل التجارب والمحاولات 🙂 ونتيجة هذه التجارب في نموذج (Search_combo 2) في نفس الملف المرفق، لعل أحد الإخوة من ذوي الخبرة ينظر فيه ويعطينا رأيه .. لأني عندما طبقت هذا الكود في قاعدة بياناتي واجهتني بعض المشاكل البسيطة في تظليل الكلمة المدخلة في مربع البحث .. فقد تكون هناك طريقة أفضل للوصول للمطلوب: البحث عن الحروف متتابعة في نفس الكلمة Search_inside_Combo X.accdb