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

السلام عليكم ورحمة الله وبركاته الأخوة والأخوات الكرام تحية طيبة وبعد،،، يوجد بالمرفقات ثلاث ملفات بعد فك الضغط 1- نموذج الـ Html باسم {ahmosAutoHtmlTemplate_V10} وتحتاج إليه فقط اذا اردت التعديل او اضافة اي شي للنموذج بشكل دائم ولإضافتة داخل البرنامج : - قم بنسخ كامل المحتوي ثم قم بتشغيل الكود التالي : [Call splitAutoTableSections] 2- ملف نصي باسم {Text_Table_Sample} ويستخدم بنسخ محتواه ثم الضغ علي الزر [Convert Copied Text To html] بالنموذج يتضمن هذا الملف مثال لجدول محدد بالعلامات التالية \t ---> vbTab علامة الفصل بين الأعمدة \n ---> vbLf علامة فصل السطور داخل الخلية \r\n -> vbNewLine علامة السطر الجديد 3- البرنامج باسم {Ahmos_AutoHtmlTable} يقوم البرنامج بتحويل الجداول الداخلية باستخدام استعلامات الـ SQL الي صفحة ويب و اي جدول خارجي عن طريق نسخ الجدول بالكامل او إذا كان الجدول علي شكل نص تم تجميعة برمجياً يوجد أمثلة كما يمكنك التجربة علي اي ملف اكسيل مع بعض الصور بعض أهم النقاط : 1- داخل هذه الوظيفة { Public Function autoTblBody } يتم معالجة محتوي الخلية للجداول الخارجية وهنا تم إضافة بعض المعاير مثل إذا كان المحتوي رقم اقل او بساوي 5 يتم توسيطة داخل الخلية اذا كانت القيم TRUE or False / YES or No يتم التوسيط وتغير اللون إذا كانت بداية الخلية = او ' يتم إزالتها وكذلك الوظيفة الخاصة بالجداول الداخلية { Public Function sqlToHtmlTbl } 2- يمكن إضافة عمود فارغ علي صفحة الـ HTML باستخدام addRecNumField = True وهو يضيف عمود recNum وفائدة هذا العمود يوجد وظيفة داخل الـ JavaScript تقوم بعمل ترقيم تلقائي لهذا العمود يتم الترقيم التلقائي عن 1- فتح الصفحة 2- عند التصدير وذلك حتي يتم تعدل الارقام علي الصفوف الظاهرة فقط 3- عند عمل إلي للتصفية Clear Filters الوظيفة هي function renumberTableColumn(columnHeadName, filterOnly = false) ويمكن ان تستخدم لترقيم اي عمود بكتابة اسم العمود بدل من columnHeadName هكذا 'recNum' اما filterOnly تحدد إذا كنت تريد ترقيم الصفوف الظاهرة فقط ام كامل الصفوف false كامل الصفوف true الظاهرة فقط اي ما يتبقي بعد البحث او التصفية 3- وظيفة saveTable تمكنك من حفظ الصفحة مرة اخري وفائدتها هي ان تقوم بحفظ نسخة اخري من الصفحة بعد حذف أعمدة او تصيفة صفوف function saveTable(deleteHiddenRows = true) وهي بشكل افتراضي تقوم بحذف الصفوف الغير ظاهرة من النسخة وليس من الأصل 4- ستجد Optional ByVal constFileName As String = "", _ داخل الوظيفة { strTbltToHtml و sqlTbltToHtml } ويسخدم هذا في تعديل هذه القيمة داخل نموذج الـ Html $fileName$ <span id="fileName" style="display: none;">$fileName$</span> وفائدتة هي وجود وظيفة في الـ java script {getExportFileName} تقوم بتحديد اسم الملف عند التصدير وتقوم بإضافة الوقت والتاريخ له فاذا كانت القيمة هنا $fileName$ او فارغة سيتم استخدام قيمة افتراضية [ahmosExTable] وغير ذلك ستسخدم أغلب وظائف الـ java script قمت بها بمساعدة الـ AI ولكن الحمد لله فاهمها بنسبة كبيرة 😁 بالتوفيق Ahmos_AutoHtmlTable_Files.zip

وعليكم السلام ورحمة الله تعالى وبركاته data.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته Sub Sheets_Arrays3() Dim lr&, LR2&, WSData As Worksheet Dim Dest As Worksheet: Set Dest = Sheets("class_room") LR2 = Dest.Cells(Dest.Rows.Count, "B").End(xlUp).Row If LR2 >= 2 Then Dest.Range("B2:S" & LR2).ClearContents Application.ScreenUpdating = False For Each WSData In Sheets(Array("كي جي1", "كي جي2", _ "الصف الأول", "الصف الثاني", "الصف الثالث", "الصف الرابع", "الصف الخامس", "الصف السادس")) lr = WSData.Cells(WSData.Rows.Count, "B").End(xlUp).Row If lr >= 3 Then LR2 = Dest.Cells(Dest.Rows.Count, "B").End(xlUp).Row + 1 Dest.Range("B" & LR2 & ":S" & (LR2 + lr - 3)).Value = WSData.Range("B3:S" & lr).Value End If Next WSData Application.ScreenUpdating = True MsgBox "تم ترحيل الفرق بنجاح", vbInformation End Sub

هلا حياكم الله واعتذر لانشغالي وعدم دخولي للموقع طبعا الي يحتاج الربط مع الزكاة والدخل انا ممكن ازودكم فقط برقم المهندس الي يساعدك في الربط مع الزكاة والدخل لاني لااستطيع نشر اي ملف خاص به لكن الرجل راح يساعدك بملف جاهز للربط والله يوفقك الجميع تم ارسال رساله للجميع

خالص الشكر لحضرتك

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

السلام عليكم مشاركة مع الاستاذ @Moosak تعديل بسيط على الكود عسى ان يكون هو المطلوب بالتوفيق ta13.rar

وعليكم السلام ورحمة الله تعالى وبركاته هناك عدة حلول تعتمد على طريقة عملك منها استخدام USERPROFILE لجعل مسار الملف ديناميكيا _ وضع المصنف في نفس مجلد ملف الماكرو أو السماح للمستخدم باختيار الملف يدويا (Browse) كما أشار الأخ الفاضل @hegazee اليك الأكواد بالترتيب المدكور يمكنك إختيار ما يناسبك Sub OpenWorkbook1() Dim xPath As String, CrWS As Workbook On Error GoTo ErrHandler xPath = Environ("USERPROFILE") & "\Desktop\aa.xlsb" ' OR <===== aa.xlsx If Dir(xPath) = "" Then MsgBox "الملف غير موجود: " & xPath, vbExclamation: Exit Sub Set CrWS = Workbooks.Open(xPath) MsgBox "تم فتح الملف بنجاح", vbInformation Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub '=================================================== Sub OpenWorkbook2() Dim xPath As String, CrWS As Workbook On Error GoTo ErrHandler xPath = ThisWorkbook.Path & "\aa.xlsb" ' OR <===== aa.xlsx If Dir(xPath) = "" Then MsgBox " :الملف غير موجود" & vbNewLine & vbNewLine & xPath, vbExclamation: Exit Sub Set CrWS = Workbooks.Open(xPath) MsgBox "تم فتح الملف بنجاح", vbInformation Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub '================================================== Sub OpenWorkbook3() Dim xPath As String, CrWS As Workbook On Error GoTo ErrHandler xPath = Application.GetOpenFilename("إختيار الملف (*.xls*), *.xls*") If xPath = "False" Then MsgBox "تم إلغاء العملية", vbInformation: Exit Sub Set CrWS = Workbooks.Open(xPath) MsgBox "تم فتح الملف بنجاح: " & xPath, vbInformation Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub وفي حالة الرغبة في التحقق من أن إسم الملف الذي يختاره المستخدم يطابق إسم معين مثلا aa.xlsb قبل فتح الملف Sub OpenWorkbook4() Dim xPath$, CrWS As Workbook,Sname$ On Error GoTo ErrHandler Sname = "aa.xlsb" xPath = Application.GetOpenFilename("إختيار الملف (*.xls*), *.xls*") If xPath = "False" Then: MsgBox "تم إلغاء العملية", vbInformation: Exit Sub fileName = Dir(xPath) If StrComp(fileName, Sname, vbTextCompare) <> 0 Then MsgBox "اسم الملف غير مطابق" & vbNewLine & Sname, vbCritical Exit Sub End If Set CrWS = Workbooks.Open(xPath) MsgBox " :تم فتح الملف بنجاح" & vbNewLine & vbNewLine & CrWS.name, vbInformation Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub bb.xlsb

وعليكم السلام ورحمة الله وبركاته .. اتمنى أن لا يكون هناك أمور لم تأت على ذكرها 😅😅 جرب في حدث عند التحميل لأي نموذج يحتوي الزر المطلوب ، الكود التالي Private Sub Form_Load() If Time() > #3:00:00 PM# Then Me.Alborg.Visible = False Else Me.Alborg.Visible = True End If End Sub

وعليكم السلام ورحمة الله و بركاته نعم، يمكن تعديل الكود ليعمل على فتح الملف من أي كمبيوتر بشرط أن يتم اختيار الملف يدويًا من خلال نافذة اختيار الملفات (File Dialog)، بدلاً من تحديد مسار ثابت مثل C:\Users\.... إليك أخي الكريم الكود المعدل ليعرض نافذة لاختيار الملف يدويًا: Sub ImportDataFromAnotherExcelFile() Dim FilePath As String Dim wb As Workbook ' فتح نافذة اختيار الملف With Application.FileDialog(msoFileDialogFilePicker) .Title = "اختر ملف Excel" .Filters.Clear .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm" If .Show = -1 Then ' تم اختيار الملف FilePath = .SelectedItems(1) Else MsgBox "لم يتم اختيار أي ملف.", vbExclamation Exit Sub End If End With ' فتح الملف Set wb = Workbooks.Open(FilePath) ' يمكنك الآن استخدام wb كمؤشر للملف المفتوح MsgBox "تم فتح الملف بنجاح: " & wb.Name End Sub bb2.xlsb

جرب هذا الشيء UNIQUE EXTRA LIST.rar