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

ملاحظاتي: - أتعبني تحويل رقم اللون الطويل إلى هيكس Hex أرقام سداسية إن صح التعبير واضطررت لعمل دالة لمعالجة مخرجات الدالة الأصل. - لم أصل إلى نوع مقاس الخط لأتمكن من حويلة بشكل دقيق فاضطررت لاستخدام رقم تقريبي بتقسيمه على 3.5 . - استخدمت كل خصائص الخط في صندوق كلمة/نص البحث ما عدا اسم الخط. - حاليا تبديل خصائص الخط في صندوق البحث يدويا (في طور التصميم) ويمكنكم إضافة تعديله بواسط الأزرار والخيارات في طور التشغيل. - مسموح للجميع التطوير فيه مباشرة وبدون إذن. - الدالة مصممة ليستفاد منها في الاستعلامات وفي الجداول لحقول المذكرة. Option Compare Database Option Explicit Function myHex(Color As Long) As String Dim hexStr As String hexStr = Hex(Color) If Len(hexStr) = 6 Then hexStr = Right(hexStr, 2) & Mid(hexStr, 3, 2) & Left(hexStr, 2) Else hexStr = Left(Right(hexStr, 2) & Left(hexStr, Len(hexStr) - 2) & "000000", 6) End If myHex = "#" & hexStr End Function Function RichText(ByVal sText As Variant, frmCtl As String) As String Dim sWord As String Dim lStr As String Dim rStr As String Dim sPos As Integer Dim fSize As Double sPos = InStr(1, frmCtl, ",") With Forms(Left(frmCtl, sPos - 1)).Controls(Right(frmCtl, sPos + 1)) sText = PlainText(Nz(sText, "")) sWord = PlainText(Nz(.Value, "")) rStr = "</font>" lStr = "<font color=""" & myHex(.ForeColor) & """>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) 'sText = Replace(Replace(sText, rStr & " " & lStr, " ", 1), rStr & "" & lStr, "", 1) lStr = "<font style='BACKGROUND-COLOR:" & myHex(.BackColor) & "'>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) fSize = .FontSize / 3.5 'تحويل تقريبي lStr = "<font size=" & fSize & "pt>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) If .FontBold Then lStr = "<b>": rStr = "</b>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) End If If .FontItalic Then lStr = "<i>": rStr = "</i>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) End If If .FontUnderline Then lStr = "<u>": rStr = "</u>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) End If End With RichText = sText End Function RichTextHighlight_01.accdb

تفضل اخي Sub Save_PDF() 'Save an array of sheets '1/2/3 Dim ws As Variant Dim i As Integer, sh As String Path = ThisWorkbook.Path & "\" Application.ScreenUpdating = False Dim weekSheet As Worksheet For Each ws In Sheets(Array("الأول", "الثاني", "الثالث")) With ws .Activate Set weekSheet = ActiveSheet weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & weekSheet.Name & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End With Next For i = 1 To 3 sh = sh & Chr(10) & Chr(10) & ThisWorkbook.Sheets(i).Name Next MsgBox "تم حفظ الملفات بنجاح" & sh, vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "معلومات" Application.ScreenUpdating = True End Sub تفضل استاد Sub Save_PDF2() 'Save an array of sheets '4/5/6 Dim ws As Variant Dim Chemin As String Dim weekSheet As Worksheet With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False .Title = "اختيار مسار حفظ الملفات" If .Show = -1 Then Chemin = .SelectedItems(1) & "\" For Each ws In Sheets(Array("السادس", "الخامس", "الرابع")) With ws .Activate Application.ScreenUpdating = False Set weekSheet = ActiveSheet weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin & weekSheet.Name & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End With Next MsgBox (": تم حفظ الملفات بنجاح في " & vbLf & vbLf & vbLf & .SelectedItems(1)), vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "معلومات" Else Exit Sub End If End With Application.ScreenUpdating = True End Sub بالتوفيق .... احصاء V2.xlsb

كذلك يمكن استخدام INDEX مع MATCH خاصة إذا كان النطاق طويل داله (1).xlsx

وهذا اختصار لمعادلة أخي الفاضل @أبوأحـمـد =INDEX($H$19:$J$19,MATCH(1,--(H20:J20<>0),0)) بالتوفيق

تفضل جرب لاكن لازم الاخد بالاعتبار عند تشغيله على ملف اخر يجب عليك تعديل مكان تموضع الشيتات مثلا هنا حددنا من الشيت الاول الى الشيت الثالث في ترتيب اوراق العمل For i = 1 To Sheets.Count - 3 وهنا حددنا من الشيت الرابع الى اخر شيت على الملف المرفق For i = 4 To Sheets.Count يتبقى لك تعديلهم بما يناسيك Sub SAVE_PDF1() 'Save an array of sheets '1/2/3 Dim Path As String Path = ThisWorkbook.Path & "\" Application.ScreenUpdating = False For i = 1 To Sheets.Count - 3 Sheets(i).Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & ActiveSheet.Name & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Next MsgBox "تم حفظ الملفات بنجاح" End Sub الكود الثاني Sub SAVE_PDF2() 'Save an array of sheets '4/5/6 Dim Chemin As String Application.ScreenUpdating = False With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False .Title = "اختيار مسار حفظ الملفات" If .Show = -1 Then Chemin = .SelectedItems(1) & "\" Else Exit Sub End If For i = 4 To Sheets.Count Sheets(i).Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin & ActiveSheet.Name & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Next End With MsgBox "تم حفظ الملفات بنجاح" End Sub احصاء V3.xlsb

نعم اخي يمكننا فعل دالك تفضل Sub All_School() Dim Réf, A(), i&, F&, Y&, K&, last&, Sh As Variant Dim Dest As Worksheet: Set Dest = Sheets("All_School") last = Dest.Cells(Rows.Count, "a").End(xlUp).Row + 1 Application.ScreenUpdating = False ' يمكنك اظافة اسماء اوراق العمل المرغوب جلب البيانات منها بالطريقة التالية ' For Each Sh In Sheets(Array("class1", "class2", "class3", "class4", "class5", "class6")) 'هنا تمت اظافة 3 اوراق فقط للتجربة For Each Sh In Sheets(Array("class1", "class2", "class4")) K = Sh.Range("B" & Rows.Count).End(xlUp).Row Réf = Sh.Range("B5:E" & K) For i = 1 To UBound(Réf, 1) Dest.Range("A5:E" & last).ClearContents Y = Y + 1: ReDim Preserve A(1 To UBound(Réf, 2), 1 To Y) For F = 1 To UBound(Réf, 2) A(F, Y) = Réf(i, F) Next Next With Dest Dest.Range("B5").Resize(Y, UBound(A, 1)) = Application.Transpose(A) End With Next Sh For F = 5 To Dest.Cells(Rows.Count, "B").End(xlUp).Row If Dest.Cells(F, "B").Value <> "" Then Dest.Cells(F, "a").Value = F - 4 End If Next F End Sub تجميع التلاميذ 4.xlsm

حياك الله أستاذ أنا كانت حاجتي التحويل من الرقم الطويل إلى هيكس. وكنت قد صممت نفس الدالتين وأعتقد كان في منتدى الاكسل ولكن من الصعب أن أبحث عنهما، فأنا لا أحتفظ بأعمالي. عموما وجدت في النت بديلا عن دوالي: 'Author : Mike Wolfe Function ConvertColorToRgb(ColorValue As Long) As String Dim Red As Long, Green As Long, Blue As Long Red = ColorValue Mod 256 Green = ((ColorValue - Red) / 256) Mod 256 Blue = ((ColorValue - Red - (Green * 256)) / 256 / 256) Mod 256 ConvertColorToRgb = "RGB(" & _ Red & ", " & _ Green & ", " & _ Blue & ")" End Function ومنها نستطيع استخدام الدالة التي جلبتها أنت RGBToHex وشكرا لأساتذة تشريفهم موضوعي.

الحمدلله 🙂 انا احلت الاستعلام qry_Section_Gender_Count على التقاعد ، واستعملت الاستعلام qry_Section_Gender_Count_2 بدلا عنه في التقارير.

يمكنك استثناء اي ورقة عمل بالطريقة التالية لنفترض اننا اردنا عدم جلب بيانات الورقة 1 والورقة 2 مثلا . If Sheets(sh).Name <> wsData.Name And Sheets(sh).Name <> "ورقة1" And Sheets(sh).Name <> "ورقة2" Then اما بالنسبة لتنسيق عمود المسلسل فقد تمت مراعات دالك داخل الكود Sub All_School() Dim i As Long, sh As Integer, lig As Long, j As Integer Dim wsData As Worksheet: Set wsData = Sheets("All_School") With wsData Application.ScreenUpdating = False .Range("A5:D" & .Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents For sh = 1 To Sheets.Count If Sheets(sh).Name <> wsData.Name And Sheets(sh).Name <> "ورقة1" Then For i = 5 To Sheets(sh).Range("B" & Rows.Count).End(xlUp).Row + 1 If .Range("B5") = "" Then lig = 5 Else lig = .Range("B" & Rows.Count).End(xlUp).Row + 1 For j = 2 To .Cells(4, Columns.Count).End(xlToLeft).Column .Cells(lig, j) = Sheets(sh).Cells(i, j) For F = 5 To wsData.Cells(Rows.Count, "B").End(xlUp).Row If wsData.Cells(F, "B").Value <> "" Then wsData.Cells(F, "a").Value = F - 4 End If Next F Next Next End If Next End With End Sub تجميع التلاميذ 3.xlsm

السلام عليكم 🙂 اطال الله في عمرك اخي الكريم ، انت خلطت الحابل بالنابل !! في معادلاتك التالية ، انت استخدمت كلمة "أنثى" ، بينما في الجدول هي "انثى" (لاحظ حرف الالف) : NF: DCount("Gender","tbl_Employees","[Gender]='أنثى' AND [system]='نصف داخلي' AND [Section] ='" & [Section] & "'") DF: DCount("Gender","tbl_Employees","[Gender]='أنثى' AND [system]='داخلي' AND [Section] ='" & [Section] & "'") . وفي هذا السطر ، لديك مسافة زائدة في نهاية كلمة 'نصف داخلي ' NH: DCount("Gender","tbl_Employees","[Gender]='ذكر' AND [system]='نصف داخلي ' AND [Section] ='" & [Section] & "'") وعلى هذا الاساس ، قام الاكسس بإعطائك النتائج الخطأ 🙂 على العموم ، مثل ما المثل يقول: رُب ضارة نافعة ، لأننا نتفادى استعمال DCount و DLookup واخواتهم في استعلام ، حيث انها تعمل بطئ في الاستعلام (طبعا لما تكون عندك آلاف السجلات) ، وعليه ، عملت لك استعلام آخر: . وجعلته مصدر بيانات التقرير : . جعفر 1571.base2023.accdb.zip

سلمت يمناك أبو أحمد 🙂 استوقفتني هذه الجملة وقد مررت سابقا بموقف مشابه ، والآن مع وجود الذكاء الاصطناعي سألته يعطيني دالتين للتحويل بين أكواد ال RGB وال Hex فما قصر وأعطاني التالي ( بدون تجربة ) 🙂 : '=================== (To convert RGB to Hex:) Function RGBToHex(ByVal red As Integer, ByVal green As Integer, ByVal blue As Integer) As String RGBToHex = "#" & Right("0" & Hex(red), 2) & Right("0" & Hex(green), 2) & Right("0" & Hex(blue), 2) End Function '=================== (To convert Hex to RGB:) Function HexToRGB(ByVal hexCode As String) As Variant Dim red As Integer, green As Integer, blue As Integer If Left(hexCode, 1) = "#" Then hexCode = Right(hexCode, Len(hexCode) - 1) End If red = Val("&H" & Mid(hexCode, 1, 2)) green = Val("&H" & Mid(hexCode, 3, 2)) blue = Val("&H" & Mid(hexCode, 5, 2)) HexToRGB = Array(red, green, blue) End Function '=================== (Here's an example of how you can use these functions:) Sub TestColorConversion() Dim red As Integer, green As Integer, blue As Integer Dim hexCode As String Dim rgbResult As Variant ' Convert RGB to Hex red = 255 green = 0 blue = 128 hexCode = RGBToHex(red, green, blue) Debug.Print "Hex Code: " & hexCode ' Convert Hex to RGB hexCode = "#00FF00" rgbResult = HexToRGB(hexCode) red = rgbResult(0) green = rgbResult(1) blue = rgbResult(2) Debug.Print "RGB: (" & red & ", " & green & ", " & blue & ")" End Sub

شكرا جزيلا اخوي ابو احمد 🙂

لم أجد .. ولم يمر علي سابقا 🙂 حتى الذكاء الاصطناعي عجز عنها 😅

هدا بسبب عدم تفريغك للبيانات القديمة لقد تم تزويدك من قبل باكواد اسرع واسهل من هدا بكثير على العموم تفضل تم تعديل المرفق كل عام وانت بخير (2).xlsm

اخي ملفك مليئ بالاخطاء وغير منظم لاكنني ساقوم باصلاح كود الترحيل فقط على حسب طلبك بنفس طريقة اشتغالك قم بوضع الكود هكدا . Private Sub CmdADD_Click() Dim last As Long If Me.TextBox2 = Empty Then: Exit Sub With sheet1 last = .Cells(.Rows.Count, "b").End(xlUp).Offset(1, 0).Row sheet1.Cells(last, "B").Value = Me.TextBox2.Value ' الرقم التعريفي sheet1.Cells(last, "C").Value = Me.TextBox15.Value 'الرقم التسجيل sheet1.Cells(last, "E").Value = Me.TextBox8.Value ' اللقب sheet1.Cells(last, "D").Value = Me.TextBox16.Value 'الاسم sheet1.Cells(last, "G").Value = Me.TextBox10.Value 'مكان الميلاد sheet1.Cells(last, "F").Value = Me.TextBox11.Value 'تاريخ الميلاد sheet1.Cells(last, "AE").Value = Me.TextBox9.Value 'اللقب بالاتننية sheet1.Cells(last, "AF").Value = Me.TextBox17.Value 'الاسم بالاتننية sheet1.Cells(last, "AG").Value = Me.TextBox18.Value 'مكان الميلاد بالاتننية sheet1.Cells(last, "AH").Value = Me.TextBox19.Value 'ولاية sheet1.Cells(last, "AC").Value = Me.TextBox12.Value 'تخصص sheet1.Cells(last, "AD").Value = Me.TextBox20.Value 'تخصص بالاتننية sheet1.Cells(last, "AI").Value = Me.TextBox13.Value ' رقم الوسيط sheet1.Cells(last, "AJ").Value = Me.TextBox21.Value ' رقم هاتف End With Me.TextBox2.Value = "" Me.TextBox15.Value = "" Me.TextBox16.Value = "" Me.TextBox8.Value = "" Me.TextBox10.Value = "" Me.TextBox11.Value = "" Me.TextBox9.Value = "" Me.TextBox17.Value = "" Me.TextBox18.Value = "" Me.TextBox19.Value = "" Me.TextBox12.Value = "" Me.TextBox20.Value = "" Me.TextBox13.Value = "" Me.TextBox21.Value = "" MsgBox "تم ترحيل البيانات بنجاح", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "تأكيد" ThisWorkbook.Save End Sub

شكرا جزيلا ابو احمد 🙂

تم بحمد لله الوصول الي حل المشكلة وما زال استاذنا صاحب الفكرة والكود مبدع كالعادة 1- تسجيل اسم الحقل كما هو بالجدول وليس الاسم البرمجي في النموذج 2- الغاء تسجيل مصدر النموذج تتبع جميع حركات المستخدم 1.01.rar