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

جرب هذا الملف( بدون كود) EHSAA3.xlsm

تفضل 🙂 Private Sub TabCtl0_Change() 'page name Me.ss1 = Me.TabCtl0.Pages.Item(TabCtl0.Value).Name 'OR 'page caption Me.ss1 = Me.TabCtl0.Pages.Item(TabCtl0.Value).caption End Sub جعفر

السلام عليكم برنامج محاسبة الشركات اهداء لكم برنامج محاسبة الشركات الاصدار الرابع سلوم 0787787573.rar

بناءا على طلب العديد من الاصدقاء قمت بعمل دورة مجانية لتعليم برمجة الاكسس لمتابعة الدورة للمبتدئين عبر هذا الرابط

السلام عليكم طريقة عمل ترقيم تلقائي لبيانات جدول على الاكسل مرفق ملف العمل وفيديو يشرح الطريقة الارقام اوتو.xlsx

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

السلام عليكم هل هذا ماتريد برنامج شركة 1السما للنقل والتوريدات.xlsm

شكرا لاستاذنا السيد جمال على الموضوع الجميل والمعلومات الرائعة زادك الله علما ونفع بك

محاولة لا اكثر اعتقد اننا نحتاج لاستعلام تحديث كما فى المرفق test3.accdb

السلام عليكم خطأ فقط استبدل + بعلامة الفاصله المنقوطة ; واذا كان لديك بالويندوز الفاصلة العاديه استخدمها , معادلة S15 =MOD( SUM( H6;J6;L6;N6;P6;D9;F9;H9;J9;L9;N9;P9;D12;F12;H12;J12;L12;N12);100) معادلة T15 =SUM(I6;K6;M6;O6;Q6;E9;G9;I9;K9;M9;O9;Q9;E12;G12;I12;K12;M12;O12)+INT(SUM(H6;J6;L6;N6;P6;D9;F9;H9;J9;L9;N9;P9;D12;F12;H12;J12;L12;N12)/100)

اذا كان الرقم عدد الارقام ثابت استعلام 2 Expr1: Right([Girlid];8) اذا كان غير ثابت استعلام 3 Expr1: Right([Girlid];Len([Girlid])-1) استعلام 3 يكفي في جميع الحالات test2.accdb

السلام عليكم 🙂 اللغة العربية هي المطلوبة هنا 🙂 المرفق المضغوط فيه مجلد وبرنامج اكسس ، والبرنامج اللي يعمل لنا QR code الموجود على الرابط التالي: https://sourceforge.net/projects/zint/ ويتم حفظ الصورة هنا Data > QR_images وعلشان كل شيء يشتغل تمام ، رجاء لا تعمل تغيير في مكان الملفات ولا المجلدات ، ولا تغيير اسمائها (طبعا تقدر تعمل اللي تريد ، بس على اساسه يجب تغيير الكود كذلك) وهي النتيجة: وخلونا نشوف من يقدر يقرأ الصورة 🙂 ----------------------------------------------------------------------------- إضافة في يوم الثلاثاء 7 / 5 / 2019 : عملت مثال يعمل على 2003 🙂 ----------------------------------------------------------------------------- إضافة في يوم الجمعة 14 / 6 / 2019 : باركود بطاقة دخول الطائرة (Boarding card) وهي من نوع PDF417 اختار الحقول اللي تريدها تظهر في QR code بإختيار مربع صح/خطأ : . والنتيجة: . و باركود 128 (ويمكن عمل اي نوع من انواع الباركود) . والتقرير (وبعد اذن اخي محمد سلامه ، فقد استعملت الصورة التي استعملها في مثاله 🙂 ) . وبهذه الطريقة نرى اننا لا نحتاج ان نحفظ صورة لكل سجل (واذا اردنا ذلك ، فنعمل تعديل في الكود ليقوم بذلك). وهذا الكود مضافا اليه عمل الباركود العادي : Private Sub Make_QR_Barcode() ' 'https://sourceforge.net/projects/zint/ ' If Len(Me.str_Text & "") = 0 Then Exit Sub Dim App_Name As String Dim Output_File As String Dim Output_Text As String Dim Encoding As String Dim Command_Line As String App_Name = Chr(34) & Application.CurrentProject.Path & "\Data\zint.exe" & Chr(34) Output_Text = Chr(34) & Me.str_Text & Chr(34) 'QR code Output_File = Chr(34) & Application.CurrentProject.Path & "\Data\QR_images\" & "QR_code.png" & Chr(34) Command_Line = App_Name & " -o " & Output_File & " --rotate=0 --eci=24 --scale=2 -w 10 --height=100 --barcode=58 -d " & Output_Text 'Debug.Print Command_Line Shell_n_Wait Command_Line, vbHide 'Barcode 128 Output_File = Chr(34) & Application.CurrentProject.Path & "\Data\QR_images\" & "Barcode.png" & Chr(34) Command_Line = App_Name & " -o " & Output_File & " --rotate=0 -d " & Me.ID 'Debug.Print Command_Line Shell_n_Wait Command_Line, vbHide 'PDF 417 Output_File = Chr(34) & Application.CurrentProject.Path & "\Data\QR_images\" & "PDF_417.png" & Chr(34) Command_Line = App_Name & " -o " & Output_File & " --rotate=0 --eci=24 --binary --barcode=55 --mode=3 -d " & Output_Text 'Debug.Print Command_Line Shell_n_Wait Command_Line, vbHide End Sub ----------------------------------------------------------------------------- إضافة في يوم الجمعة 22 / 6 / 2019 : تم عمل VCard QR ليخزن معلومات الشخص مباشرة في الموبايل 🙂 . وبإستخدام برامج الموبايل والتي تقرأ QR Code ، يمكنك حفظ معلومات VCard QR مباشرة في عناوين الموبايل 🙂 البرنامج zint الموجود في المرفق ، فيه امكانية عمل عدة انواع من QR والباركودات ، ولكن كل نوع من هذه الانواع له صيغة خاصة في عمله ، فمثلا كود VCArd QR هو: Function Add_Items() Dim VCard_Text As String 'clear field VCard_Text = "" VCard_Text = "BEGIN:VCARD" & vbCrLf VCard_Text = VCard_Text & "VERSION:3.0" & vbCrLf VCard_Text = VCard_Text & "N:" & Me.[Family Name] & ";" & Me.[Given Name] & ";" & Me.[Additional Name] & ";" & Me.[Name Prefix] & ";" & vbCrLf VCard_Text = VCard_Text & "FN:" & Me![Name] & vbCrLf VCard_Text = VCard_Text & "ORG:" & Me.[Organization 1] & vbCrLf VCard_Text = VCard_Text & "TEL;TYPE=" & Me.[Phone 1 - Type] & ",VOICE:" & Me.[Phone 1 - Value] & vbCrLf VCard_Text = VCard_Text & "TEL;TYPE=" & Me.[Phone 2 - Type] & ",VOICE:" & Me.[Phone 2 - Value] & vbCrLf VCard_Text = VCard_Text & "TEL;TYPE=" & Me.[Phone 3 - Type] & ",VOICE:" & Me.[Phone 3 - Value] & vbCrLf VCard_Text = VCard_Text & "ADR;:" & ";;" & Me.[Address 1] & ";;;;" & vbCrLf VCard_Text = VCard_Text & "BDAY:" & Me.[Birthday] & vbCrLf VCard_Text = VCard_Text & "EMAIL;TYPE=" & Me.[E-mail 1 - Type] & ":" & Me.[E-mail 1 - Value] & vbCrLf VCard_Text = VCard_Text & "EMAIL;TYPE=" & Me.[E-mail 2 - Type] & ":" & Me.[E-mail 2 - Value] & vbCrLf VCard_Text = VCard_Text & "NOTE:" & Me.Notes & vbCrLf VCard_Text = VCard_Text & "URL:" & Me.[Website 1] & vbCrLf VCard_Text = VCard_Text & "END:VCARD" Add_Items = VCard_Text End Function والذي يختلف عن PDF417 والذي يختلف عن غيره. المرفق في ملفين بصيغة txt والذي فيهما جميع الاوامر التي يمكن استعمالها لعمل مختلف انواع الباركود 🙂 ----------------------------------------------------------------------------- إضافة في يوم السبت 2 / 11 / 2019 : هنا مثال لعمل بطاقة عمل ID.zip ، بأصغر حجم QR code (رجاء ابقاء حجمه ، فقد توصلت الى هذا الحجم والكود بعد محاولات ساعات طويلة) : . وهذا هو QR code . اما تفاصيل عمل البطاقات ، فهذا الرابط فيه تفاصيل كاملة: . جعفر ملاحظة: 1. المرفق في هذه المشاركة هو البرنامج الاخير ، وفيه جميع التعديلات التي في بقية المشاركات. 2. الـ api التي تنتظر إنتهاء الامر ، ثم تنتقل للسطر التالي في الكود اسمها ShellWait ، هذه لا تتعامل مع Unicode / utf-8 / ومنها الحروف العربية بطريقة صحيحة : http://access.mvps.org/access/api/api0004.htm بينما هذه تمام : https://github.com/xxdoc/vb6-Shell-Wait/blob/master/Shell %26 Wait v2/modShellWait.bas zint QR 3.zip ID.zip Shell_n_Wait_2021-12-13.txt.zip

ممكن ان يكون الحل Crezy_sequance.xlsx

بعد اذن الاستاذ هذا الكود يطبع جميع الشيتات باستثناء شيت DATA ويمكنك تعديله حسب المدى المطلوب sub test 'كود طباعة جميع الشيتات dim ws as worksheet dim sh as worksheet: set sh = sheets("DATA") ' الشيت المستثنى من الطباعة Dim lr As Long For Each ws In Sheets lr = ws.Range("a" & Rows.Count).End(xlUp).Row If ws.Name = "DATA" Then GoTo 1 ' الشيت داتا سميه ما شئت ولك غيره في السطر الثاني و السادس ws.Range("a1:g" & lr).PrintOut 1: Next ws end sub

تم التعديل كما تريد Option Explicit Sub transfer_data() Dim Source_sh As Worksheet Dim Target_sh As Worksheet Dim last_ro%, N_ro% Set Source_sh = Sheets("ورقة1") last_ro = Source_sh.Cells(Rows.Count, 3).End(3).Row If last_ro < 10 Then Exit Sub Select Case Source_sh.Range("c2") Case "أ": Set Target_sh = Sheets("نوبة أ") Case "ب": Set Target_sh = Sheets("نوبة ب") Case "ج": Set Target_sh = Sheets("نوبة ج") Case "د": Set Target_sh = Sheets("نوبة د") Case "ه": Set Target_sh = Sheets("نوبة ه") Case "و": Set Target_sh = Sheets("نوبة و") End Select N_ro = Target_sh.Cells(Rows.Count, 1).End(3).Row + 1 Target_sh.Range("a" & N_ro).Resize(last_ro - 9, 6).Value = _ Source_sh.Range("B10").Resize(last_ro - 9, 6).Value End Sub الملف مرفق EHSAA3_1.xlsm

الشرح موضح بالصور

بعد اذن الاخ علي هذا الكود Option Explicit Sub get_data() Rem ====>> Created By Salim Hasbaya On 2/11/2019 Dim Sh1 As Worksheet, Sh2 As Worksheet Dim tabL1 As Range Dim i%, Ro%, x% Set Sh1 = Sheets("Sheet1") Set Sh2 = Sheets("Sheet2") Set tabL1 = Sh1.Range("A1").CurrentRegion Sh2.Cells(9, 3).Resize(100, 500).ClearContents Ro = tabL1.Rows.Count For i = 3 To 95 Step 3 tabL1.AutoFilter 1, Sh2.Cells(5, i) x = tabL1.SpecialCells(12).Count If x > 4 Then tabL1.Offset(1).Resize(Ro - 1) _ .SpecialCells(12).Offset(, 1).Resize(, 3).Copy _ Sh2.Cells(9, i) End If Next i If Sh1.AutoFilterMode Then Sh1.ShowAllData: tabL1.AutoFilter End If End Sub الملف مرفق tarhil.xlsm

بالتوفيق فكرة رائعة جزاكم الله خيرا

استبدل المعادلة بهذه

تفضل 🙂 تصحيح فني ، ولا علاقة له بالموضوع: هذه الطريقة خطأ Option Compare Database Dim UserRS As Recordset Option Explicit Public UsN Public UsM والطريقة الصحيحة Option Compare Database Option Explicit Dim UserRS As Recordset Public UsN Public UsM . والخطأ كان في هذا السطر: Set UserRS = DB.OpenRecordset(" SELECT tbl_User.* FROM tbl_User WHERE tbl_User.user_name ='" & UsN & "' AND tbl_User.City='" & UsM & "';", dbOpenDynaset) ولكنك لم تخبر البرنامج ما هو المتغير DB ، لهذا السبب يمكننا تغيير الكود الى التالي: Set UserRS = CurrentDb.OpenRecordset(" SELECT tbl_User.* FROM tbl_User WHERE tbl_User.user_name ='" & UsN & "' AND tbl_User.City='" & UsM & "';", dbOpenDynaset) ويمكن اختصاره الى Set UserRS = CurrentDb.OpenRecordset(" SELECT * FROM tbl_User WHERE user_name ='" & UsN & "' AND City='" & UsM & "';", dbOpenDynaset) . جعفر

أحسنت استاذ عبد اللطيف عمل رائع جعله الله فى ميزان حسناتك

السلام عليكم وماهيا المشكلة لابد من توضيح بارك الله فيك

ولا اى شئ اخى جعفر كلنا هنا اخوان متحابين اخى حسين هل لك ان تدلنى على شرح او موضوع كيف احمى السورس كود الخاص ببرامجى فانا لا امتلك مثل هذه المهارة ؟ والله ما زاد جمالا الا بتعليقك اخى ابو خليل 🌺

الخلايا ذات الالوان المتدرجه لم تعمل مع الكود فهمتني اما الخلايا التي بها لون عادي بتعمل بكفاءه لي محاولات بالتعديل على الكود اذا نجحت سأرفقها

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

استاذي @ابا جودى خليك مع كود الاكسس وجرب هل يتغير بالفورمات ام لا؟ ماتفضلت به هو ليس المقصود فالرقم الذي ظهر لك في النهاية قد ظهر لي نفسه ايضاً وهذا يعني ان الكود الذي في الاكسس لايقرأ تلك القيمة انظر للصورة من جهازي

سلام عليكم عملت لحضرتك استعلام اتمناه يفي بالغرض حاجه على قد الحال - تحياتى test3.rar

مع الاسف الشديد غير صحيح تابع معى الخطوات الاتية Start > Run > wbemtest هذا هو الرقم اما من الاكسس

الحمد لله عرفت اعملها بالتجربة مع نفسي.. Between dmax ("[xx]" ;"tableName") and dmax ("[xx]" ;"tableName") - 10

السلام عليكم الخلايا التي بها الوان متدرجه لايجدي الكود معها لاكن بخصوص اختلاف ارجاع الالوان كما سابقتها بالامكان تصحيحه بالتعديل على الكود ليصبح كالتالي Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) MyColor = 6 If Not IsError(Sh.[N_Color_Rng]) Then If Not IsError(Sh.[N_Color_Color]) Then If Not IsError(Sh.[N_Color_Old]) Then If Sh.[N_Color_Rng].Interior.ColorIndex = Sh.[N_Color_Old] Then Dim R, G, B R = Ref_Ali(Sh.Names("N_Color_Color").RefersToR1C1, 1) G = Ref_Ali(Sh.Names("N_Color_Color").RefersToR1C1, 2) B = Ref_Ali(Sh.Names("N_Color_Color").RefersToR1C1, 3) Sh.[N_Color_Rng].Interior.Color = RGB(R, G, B) End If End If End If End If Sh.Names.Add "N_Color_Rng", ActiveCell Sh.Names.Add "N_Color_Color", G_Colr(ActiveCell) Sh.Names.Add "N_Color_Old", MyColor ActiveCell.Interior.ColorIndex = MyColor End Sub Function Ref_Ali(a, Inx) Select Case Inx Case 1 aa = Mid(a, InStr(1, a, "(") + 1, InStr(InStr(1, a, "("), a, ",") - InStr(1, a, "(") - 1) Case 2 aa = Split(a, ",")(1) Case 3 aa = Mid(Trim(Split(a, ",")(2)), 1, InStr(1, Trim(Split(a, ",")(2)), ")") - 1) End Select Ref_Ali = aa End Function Function G_Colr(Rng As Range) Dim HEX_A As String Dim Ali_R As String HEX_A = Right("000000" & Hex(Rng.Interior.Color), 6) Ali_R = "RGB (" & CInt("&H" & Right(HEX_A, 2)) & ", " & CInt("&H" & Mid(HEX_A, 3, 2)) & ", " & CInt("&H" & Left(HEX_A, 2)) & ")" G_Colr = Ali_R End Function

السلام عليكم 🙂 تفضل 🙂 'FileCopy varFile, destpath Name varFile As destpath جعفر

السلام عليكم 🙂 اخي إمام ، قوانين المنتدى تقول ، سؤال واحد لكل موضوع ، وقد تمت الاجابة على سؤالك ، فرجاء عمل موضوع جديد لسؤالك الاخير 🙂 يُغلق. جعفر

هههههههههه اعلم انك تمزح يا ابا جودى ولكن انا ادعو لك ولجميع اساتذتنا اللذين لايبخلون علينا بما علمهم الله ربنا يرضيكم ويرضى عنكم اللهم آمين طبتم واهتديتم

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

اعتقد يا @ابا جودى ان الاصدار اللى اتعمل بيه الملف اعلى من الاصدار اللى عندك ان شاء الله الاستاذ @عبد اللطيف سلوم يوضح اصدار الاوفيس اللى عنده برضه حتى نعلم ان كانت هذه هى المشكله ام يوجد مشكله اخرى والله اعلى واعلم تقبلوا تحياتى طبتم واهتديتم

مش عاوزه تشتغل عندى

السلام عليكم بالتوفيق استاذ @عبد اللطيف سلوم تقبل تحياتى طبتم واهتديتم

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

احسب عمرك معرفة عمرك بالسنين و الشهور و الأيام.xlsx

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

جرب هذا الكود Option Explicit Sub HID_COLUMNS() Dim I% Range(Cells(1, 5), Cells(1, 262)).EntireColumn.Hidden = True For I = 13 To 262 Step 8 Cells(1, I).EntireColumn.Hidden = False Next End Sub

السلام عليكم اخ امجد بارك الله فيك على كلماتك الطيبه جرب المرفق بخصوص كشف الحساب Petty Cash Excel _Ali1.xlsm

تفضل جرب المرفق اضافة بيانات لليست عن طريق تكستات بزر اضافة.xls

السلام عليكم تفضل اخي الكريم بعد اضافة الحقلين المطلوبين طلب العلم لا يصلح مع الحياء فمن حقك الطلب وواجب علي الاجابة وسامحني على التاخير فضغط العمل لا يرحم barcode.accdb

وعليكم السلام 🙂 هذا سطر حفظ الملف (انا اعطيت صورة كل نوع من الباركود اسم مختلف) ، واسم الصورة هنا QR_code.png : Output_File = Chr(34) & Application.CurrentProject.Path & "\Data\QR_images\" & "QR_code.png" & Chr(34) اذا اردت حفظ الصورة برقم ID الموظف ، سيكون الكود: Output_File = Chr(34) & Application.CurrentProject.Path & "\Data\QR_images\" & Me.ID & Chr(34) بس مثل ما انا قلت في البداية ، واقعا ما تحتاج الى صورة لكل موظف ، لأنك تحتاج تطبع الهوية والسلام ، فمافي داعي لحفظ الصورة ، وخصوصا اذا عملت تغيير في البيانات ، فالصورة القديمة لن تنفعك ، بينما طباعة هوية جديدة تعطيك جميع البيانات الجديدة 🙂 جعفر

السلام عليكم :) شكرا على ردودكم ، وتمت اضافة مثال متكامل :) جعفر

فضلا وكرما ممكن مرفق بالطريقة

مرحبا استاذ حسنين @SEMO.Pa3x فعلا انت مكسب لنا جميعا اعتقد ان الموضوع احترافي على غيره من مواضيع الحماية في المنتدى ولكن عندي مداخلة هنا : لو دخلت على حقل الباسسوورد في جدول الدخول ثم مسحت الباسوورد القديمة ووضعت رقم جديد وليكن 321 واستخدمته في شاشة الدخول هل سيقبل لان الباسوورد اصبحت متطايقة ؟ تقبل اجمل تحية

السلام عليكم حولي الوقت إلى رقم بضربه في 24 ثم يمكنك عمل كل العمليات الحسابية بدون مشاكل . مثال : InTime * 24 تحياتي .