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

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

وجدت كود ليقرأ من SQL Server مباشرة ، وتركته في البرنامج ، ولكني ام افعّله : Dim cmd As New ADODB.Command Dim RS As New ADODB.Recordset cmd.ActiveConnection = "Provider=SQLOLEDB;DataSource=yourserver;Database=yourDB;UID=test;PWD=test;" cmd.ActiveConnection.CursorLocation = adUseClient cmd.CommandText = "Select getdate()" Set RS = cmd.Execute Debug.Print RS(0) RS.Close cmd.ActiveConnection.Close . استخدم دالة Format ، بحيث time_date_server هو حقل تاريخ السيرفر ، هكذا: if format(time_date_server ,"dd/mm/yy") <> format(date() ,"dd/mm/yy") then msgbox "تاريخ السيرفر لا يطابق تاريخ الكمبيوتر" elseif format(time_date_server ,"hh") <> format(date() ,"hh") then msgbox "ساعة السيرفر لا تطابق ساعة الكمبيوتر" end if جعفر

ربما يكون المطلوب Option Explicit Dim E, W, N, S 'FROM CELL Z1 TO AC11 Dim t%, L%, letr Dim Co1(), a%, B_E As Boolean Dim Co2(), b%, B_W As Boolean Dim Co3(), c%, B_N As Boolean Dim Co4(), d%, B_S As Boolean '+++++++++++++++++++++ Sub quelque_chose() If ActiveSheet.Name <> "Salim" Then Exit Sub E = Array(193, 194, 195, 197, 199, 200, 201, _ 202, 203, 204, 205, 206, 236) W = Array(207, 208, 209, 210, 211, 212, 213) N = Array(214, 216, 217, 218, 219, 221, 222) S = Array(192, 196, 198, 223, 225, 227, 228, _ 229, 230, 237) End Sub '+++++++++++++++++++++ Sub My_test() quelque_chose Range("E2:H100").ClearContents L = Len(Cells(2, "C")) a = 1: b = 1: c = 1: d = 1 For t = 1 To L letr = Mid(Cells(2, "C"), t, 1) If letr = " " Then GoTo next_t If Asc(letr) >= 65 And _ Asc(letr) <= 122 Then GoTo next_t B_E = Not IsError(Application.Match(Asc(letr), E, 0)) B_W = Not IsError(Application.Match(Asc(letr), W, 0)) B_N = Not IsError(Application.Match(Asc(letr), N, 0)) B_S = Not IsError(Application.Match(Asc(letr), S, 0)) Select Case True Case B_E ReDim Preserve Co1(1 To a) Co1(a) = letr a = a + 1 Case B_W ReDim Preserve Co2(1 To b) Co2(b) = letr b = b + 1 Case B_N ReDim Preserve Co3(1 To c) Co3(c) = letr c = c + 1 Case B_S ReDim Preserve Co4(1 To d) Co4(d) = letr d = d + 1 Case Else GoTo next_t End Select next_t: Next If a > 1 Then Range("E2").Resize(UBound(Co1)) = _ Application.Transpose(Co1) End If If b > 1 Then Range("F2").Resize(UBound(Co2)) = _ Application.Transpose(Co2) End If If c > 1 Then Range("G2").Resize(UBound(Co3)) = _ Application.Transpose(Co3) End If If d > 1 Then Range("H2").Resize(UBound(Co4)) = _ Application.Transpose(Co4) End If End Sub الملف للمعاينة مرفق Arabic_Alphabet.xlsm

وعليكم السلام-تفضل رابط التحميل : https://www.up-4ever.org/0yc50q0spzhx سريال التنشيط : KGFVY-7733B-8WCK9-KTG64-BC7D8 باسورد فك الضغط www.mrelhlawany.com

استبدل اسم الصفحة الى Salim ( لحسن نسح الكود ولصقه بدون مشاكل اللغة العربية) ثم نفذ هذا الكود Option Explicit Dim sh As Worksheet Dim Rg As Range, cel As Range Dim my_formula '+++++++++++++++++++++++ Sub hid_Rows() Application.ScreenUpdating = False show_all For Each cel In Rg.Columns(2).Cells my_formula = _ Application.CountA(cel.Resize(, 4)) If my_formula = 0 Then cel.EntireRow.Hidden = True End If Next Application.ScreenUpdating = True End Sub '++++++++++++++++++++++++++++ Sub show_all() Set sh = Sheets("Salim") Set Rg = sh.Range("B4").CurrentRegion Rg.EntireRow.Hidden = False End Sub الملف مرفق Yesk.xlsm

بعد اذن احي المهندس جرب هذا الملف (لك حق الاختيار الحد الادنى والاقصى) Alien.xlsx

‎⁨شاشة النتيجة⁩.pptx.zip

السلام عليكم شكراً للقائمين على هذا المنتدى العملاق من مشرفين واعضاء لني تعلمت منهم الاكثير واتمنى لهم الموفقية والصحة الدائمة ان شاء الله تعالى. اخوتي انا اعرف ان في هذا المنتدى عمالقة التصميم والبرمجة وانا اعلم ان في هذا المنتدى افضل من هذا البرنامج ولكن لرد الجميل هذا المنتدى ارفع هذه نسخة من برنامج الصادر والوارد مفتوح المصدر برابط خارجي صممتة لصديق لي يعمل في شركة .... تحياتي لكم جميعاً.... https://up.top4top.net/downloadf-1058tvebj1-rar.html

الاخوة الاعزاء ، السلام عليكم لدي مجموعة من صور الطلاب ، قمت بسحب كل مجموعة منها على صفحة اسكنر كصورة واحدة مرتبين برقم الجلوس يعني الصورة الاولى برقم 1 والثانية برقم 2 وهكذا ، وبعد السحب المطلوب تقسيم كل صورة مجمعةإلى مجموعة من الصور الصغيرة كل صورة تمثل طالب ثم تحفظ خارجيا برقم جلوسه المتسلسل ومدرج معه ملف به مثال لصفحة صور مجمعة وضعتها في نموذج ارجو المساعدة وجزاكم الله كل خير Database1.rar

السلام عليكم لقد وصلت متأخرا فوجدت الأستاذ جعفر فعل كل شيء ما شاء الله عليه. لذلك سوف أضع مشاركتي على الرغم أنها تشبه كثيرا كود الأستاذ جعفر Dim str_conn As New ADODB.Connection Dim RS As New ADODB.Recordset str_conn.Open "Provider=SQLOLEDB;Integrated Security=SSPI;Initial Catalog=master;Data Source=" & Me.Comp1 Set RS = str_conn.Execute("select GETDATE()") MsgBox RS(0) Set RS = Nothing str_conn.Close Me.Comp1 هو اسم مربع اسم السرفر

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

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

تفضل اخي الكريم H_G.accdb

تفضل هذا يا يو عبدالرحمن انسخ و الصق فقط تزيين و تضبيط لكود اخونا الكبير @صالح حمادي On Error GoTo errorhandle DoCmd.Beep If MsgBox("عزيزي المستخدم انت على وشك افراغ قاعدة البيانات" & vbNewLine & "هل تريد فعلا حذف البيانات ؟", vbCritical + vbYesNo + vbMsgBoxRight, "حذف بيانات") = vbYes Then DoCmd.SetWarnings False DoCmd.RunSQL "DELETE FROM " & "CS_GetStudentScheduleReport" DoCmd.RunSQL "DELETE FROM " & "ImportSheet" DoCmd.RunSQL "DELETE FROM " & "Academic" DoCmd.SetWarnings True DoCmd.Beep MsgBox "تم حذف البيانات بنجاح", vbInformation + vbMsgBoxRight, "تأكيد" Else MsgBox "تم الغاء حذف البيانات", vbInformation + vbMsgBoxRight, "الغاء الاجراء" End If errorhandleexit: Exit Sub errorhandle: MsgBox Err.Description Resume errorhandleexit

تفضل التعديل اخي الكريم wesam.rar

السلام عليكم ضع كود الحذف بعد السطر الأول في هذا الكود : If MsgBox("هل تريد فعلا حذف البيانات", vbYesNo, "حذف بيانات") = vbYes Then 'كود الحذف Else MsgBox "لقد تم إلغاء عملية الحذف" End If

تفضل اخى الكريم اتبع الخطوات الموجودة بهذا الرابط للوصول لحل المشكلة ولكم جزيل الشكر 6 Working Solutions to Fix “Microsoft Excel has Stopped Working” Error Message وهذا فيديو ايضاً للشرح

من فضلك اتبع الخطوات كما بالصور فكل حاجة تعمل معى بكفاءة وان وجدت غير ذلك معك فيجب حل المشكلة لديك بنفسك او عليك بتغيير متصفح الإنترنت لديك أو تحديثه

في اعتقادنا ان حروف اللغة العربية 28 حرفاً لكن الاكسل لا يعرفها هكذا لأن عنده (أ , إ , ا ,آ ) كلها مختلفة ونفس الشيء بالنسبة لــ (ت , ة , و , ؤ ) الخ...... لمعرفة كل الأخرف العربية غند الاكسل هذا الماكرو Option Explicit Sub test_me() Dim i%, arr() Dim k, Non_Arabic() Dim m% Non_Arabic = Array(215, 220, 224, 226, 231, 232, 233, 234, 235) m = 1 For k = 1 To 46 If IsError(Application.Match(k - 1 + 192, Non_Arabic, 0)) Then ReDim Preserve arr(1 To m) arr(m) = Chr(k - 1 + 192) m = m + 1 End If Next m = 2: k = 2 For i = 1 To UBound(arr) Cells(m, k) = arr(i) m = m + 1 If m = 9 Then m = 2: k = k + 1 Next End Sub الملف مرفق Araabic_alpha.xlsm

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

بعد ملاحظة المرفق تبين وجود جدول مرتبط بشيت1 في ملف الإكسل ولذا يجب عدم فتح النموذج ولا البرنامج ككل إذا لم يكن الملف موجودا في المسار المحدد لذلك وبعد إذن أخي جعفر يجب استبدال exit sub إلى DoCmd.Quit للخروج النهائي من البرنامج

السلام عليكم مرفق مثال كان عندي من احد الاصدقاء و هو ليس من تصميمي يمكن يفيدك فى طلبك . و تحياتى اختيار من الجدول للتقرير.rar

السلام عليكم 🙂 لا يكفي ان تكتب رقم IP السيرفر ، بينما يجب ان تكتب اسم المجلد الذي لك فيه صلاحية الكتابة Read/Write ، مثل : . وعملنا تعديل في الوحدة النمطية ، بحيث تأخذ اسم مجلد السيرفر من حقل النموذج : Public Function Make_File3(BE_Path As String) On Error GoTo err_Make_File3 Dim PauseTime, Start 'we need the path to have a slash at its end If Right(BE_Path, 1) <> "\" Then BE_Path = BE_Path & "\" End If BE_Path = BE_Path & "dummy.txt" 'make the dummy txt file Open BE_Path For Output As #1 Print #1, "No text required" Close #1 'pasue for a second, until file is recognized, for slow networks PauseTime = 1 ' Set duration. Start = Timer ' Set start time. Do While Timer < Start + PauseTime DoEvents ' Yield to other processes. Loop 'get the date created Make_File3 = FileDateTime(BE_Path) 'clean up, delete the file Kill BE_Path Exit_Make_File3: Exit Function err_Make_File3: If Err.Number = 75 Then MsgBox "Access Denied" & vbCrLf & "لا تملك الصلاحية في الكتابة في المجلد" Else MsgBox Err.Number & vbCrLf & Err.Description End If Resume Exit_Make_File3 End Function . ونناديها من النموذج هكذا: Me.srvr_Date_Time = Make_File3(Me.srvr_Domain_Name) جعفر 1176.my_FE_Network_PC_Time.mdb.zip

يمكن ان يكون هذا المطلوب date without_sam days.xlsm

تفضل =IF(WEEKDAY(P2)=5;P2+2;P2+1) Book1 (1).xlsx

وعليكم السلام-من فضلك شوف هذا الفيديو https://www.youtube.com/watch?v=5FglGNvVcyY

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم If Me.z1 = "x" Then Me.num1.Value = Me.num1.Value - (Me.num1.Value * 2) End If z.rar تحياتي

لماذا لم توضح ذلك مسبقاً؟؟؟ عشان عدم اضاعة الوقت (كما ولم الاحظ اي رقم كما ذكرت انت) جرب هذا الملف ( المعادلة تبحث عن اخر صفر و تدرج ما بعده) M_Awada.xlsx

بعد إذن اخي سليم لو النمط ثابت على هذه الصورة EU ثم عشرة ارقام يمكنك استعمال المعادلة التالية =int(right(a3, 10)) بالتوفيق

باستخدام المعادلات countifs و sumifs جرب الملف المرفق الموردين2 عن شهر6-2020م.xlsx

تم التعدبل Option Explicit Sub del_zeros_() Dim sh As Worksheet Dim curt As Range Dim rg_to_del As Range Dim F_rg As Range Dim Ro%, i% For Each sh In Sheets If sh.Name Like "report*" Then GoTo next_sheet Ro = sh.Cells(Rows.Count, 1).End(3).Row sh.Range("A4").Resize(, 10) = vbNullString Set curt = sh.Range("E5:I" & Ro) curt.Interior.ColorIndex = xlNone For i = 1 To curt.Rows.Count Set F_rg = curt.Rows(i).Find(0, lookat:=1) If F_rg Is Nothing Then GoTo next_row If rg_to_del Is Nothing Then Set rg_to_del = curt.Rows(i) Else Set rg_to_del = Union(rg_to_del, curt.Rows(i)) End If next_row: Next i If Not rg_to_del Is Nothing Then ' rg_to_del.Delete rg_to_del.Interior.ColorIndex = 35 End If Set rg_to_del = Nothing next_sheet: Next End Sub

تم معالجة الأمر مع تغيير بسيط في تصميم اليوزر New_UNIQ_DATA.xlsm

معادلات ممتازة لكنها كثيرة 12 معادلة (كل 6 أعمدة يجب تغييرها) يمكن اختصار الكل الى معادلة واحدة تكتب في الخلية G4 وتسحب ييميناٌ ثم نزولاً =IFERROR(OFFSET(INDIRECT("'"&OFFSET($G$2,,INT((COLUMNS($A$1:A1)-1)/6)*6)&"'!"&"C$"&ROWS($A$1:A5)),,CHOOSE(MOD(COLUMNS($A$1:A1)-1,6)+1,35,36,37,38,39,40)),"") Saef _Extra.xlsx