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

ممكن تستفيد من هذا الموضوع ...

هل هذا ما تقصدة .....

أشكرك أخي الفاضل لكن هي ليست عبقرية ولكن استخدام قاعدة IF في الاستعلام فقط ...... فبل كل شيئ لفهم ذلك انصحك بعدم استخدام المسميات العربية في تسمية حقول الجداول أو اسماء الجداول قدر الامكان : ببساطة استخدمنا هذا في الاستعلام : D: IIf([1]="2";[المبلغ]-[النسبة];"0") شرح الرموز لأني حولتا رموز وارقام حتى نفهمها لأني لو كتبتها بالعربية تتغير مواقعها ولا نستطيع تخيلها بالشكل المطلوب : D هو اسم الحقل ( صاقي الارباح ) 1 هو حقل الحدث 2 العبارة الموجودة في حقل الحدث ( ذاهب ) إذن قاعدة IF تقول عند وجود عبارة ذاهب في حقل الحدث اجري عملية طرح النسبة من المبلغ وفي حال عدم وجود العبارة ذاهب في حقل الحدث ارجعها صفرا ارجو ا، اكون وفقت في الشرح كلنا شوق لطرقك الجميلة ..... ( حياك استاذي رمهان .... في انتظارك )

انت جعلت الفرز حسب التاريخ .... انظر الصورة انظر المرفق بعد حذف الفرز .... Forum.mdb

دائما سباق الى الخير استاذ سليم

جرب هذا الكود Option Explicit Sub give_Data() Dim k As Byte, x%, Xera%, t%, Y% Dim my_cel, m%: m = 2 Dim col% Dim Filter_range As Range Dim Nous As Worksheet: Set Nous = Sheets("شيت نص السنة") Dim Kaleb As Worksheet: Set Kaleb = Sheets("قالب رفع الدرجات") Dim Nous_ro%: Nous_ro = Nous.Cells(Rows.Count, 1).End(3).Row Kaleb.Range("a2:t5000").ClearContents Dim Rg_Nous As Range: Set Rg_Nous = Nous.Range("a1:G" & Nous_ro) Dim Nous_r%: Nous_r% = Rg_Nous.Rows.Count Dim mY_arr(): mY_arr = Array(1, 2, 3, 4, 5, 7) With Nous If .FilterMode Then .ShowAllData .AutoFilterMode = False End If For k = 0 To 5 Rg_Nous.AutoFilter 3, mY_arr(k) Set Filter_range = Rg_Nous.Offset(1, 0).Resize(Nous_r% - 1).SpecialCells(xlCellTypeVisible) Xera = Filter_range.Areas.Count For t = 1 To Xera Y = Filter_range.Areas(t).Rows.Count Kaleb.Cells(m, 1).Resize(Y, 6).Value = _ Filter_range.Areas(t).Cells(1, 1).Resize(Y, 6).Value Select Case mY_arr(k) Case 1: col = 20 Case 2: col = 8 Case 3: col = 10 Case 4: col = 14 Case 5: col = 16 Case 7: col = 12 End Select Kaleb.Cells(m, col).Resize(Y, 1).Value = _ Filter_range.Areas(t).Cells(1, 7).Resize(Y, 1).Value m = m + Y Next t Next k .AutoFilterMode = False End With give_Data1 End Sub Rem============================================= Sub give_Data1() Dim k As Byte, x%, Xera%, t%, Y% Dim my_cel, m%: m = 2 Dim col% Dim Filter_range As Range Dim Shahr As Worksheet: Set Shahr = Sheets("شيت الشهري") Dim Kaleb As Worksheet: Set Kaleb = Sheets("قالب رفع الدرجات") Dim Shahr_ro%: Shahr_ro = Shahr.Cells(Rows.Count, 1).End(3).Row Dim Rg_Shahr As Range: Set Rg_Shahr = Shahr.Range("a1:G" & Shahr_ro) Dim mY_arr(): mY_arr = Array(1, 2, 3, 4, 5, 7) With Shahr If .FilterMode Then .ShowAllData .AutoFilterMode = False End If For k = 0 To 5 Rg_Shahr.AutoFilter 3, mY_arr(k) Set Filter_range = Rg_Shahr.Offset(1, 0).Resize(Shahr_ro - 1).SpecialCells(xlCellTypeVisible) Xera = Filter_range.Areas.Count For t = 1 To Xera Y = Filter_range.Areas(t).Rows.Count Select Case mY_arr(k) Case 1: col = 20 Case 2: col = 8 Case 3: col = 10 Case 4: col = 14 Case 5: col = 16 Case 7: col = 12 End Select Kaleb.Cells(m, col - 1).Resize(Y, 1).Value = _ Filter_range.Areas(t).Cells(1, 7).Resize(Y, 1).Value m = m + Y Next t Next k .AutoFilterMode = False End With End Sub الملف simple_data.xlsm

السلام عليكم راجع الملف المرفق لعل فيه ما تريد... تحويل ثلاث ارقام من اليمين الى اصفار.xlsx

1-حيث ان البيانات كثيرة جداً فقد تم اختصار الملف الى حوالي 100 اسم للتحقق من عمل الماكرو (يمكن الان تعميم الماكرو على كل الملف) 2-هناك خلايا مدمجة في الملف مما يعيق عمل الماكرو (تم التعدبل على بنية الملف لازالة الخلايا المدمجة) 3-في المرة المقبلة حاول تجنب الخلايا المدمحة واختصار الملف الى أقل عدد ممكن من البيانات 4- تم معالجة الامر في الملف المرفق 5- ارجو ان ينال الاعجاب الكود Option Explicit Sub Give_Me_Data_Please() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim Data As Worksheet Dim ws2 As Worksheet Set Data = Sheets("data") Set ws2 = Sheets("Archive") With ws2 .Range("a38:j10000").ClearContents .Range("c10:j34").ClearContents End With Dim Capcity%, i%, k%, Max_ro% Dim ro%: ro = 39 Dim first_row%: first_row = 10 Dim lr_data% lr_data = Data.Application.Max(Data.Range("A:A")) Capcity = lr_data \ 25 If lr_data Mod Capcity > 0 Then Capcity = Capcity + 1 For k = 1 To Capcity - 1 ws2.Range("c5:j37").Copy ws2.Range("c" & ro) ro = ro + 33 Next For i = 6 To lr_data + 25 Step 25 ws2.Range("c" & first_row).Resize(25, 5).Value = _ Data.Range("a" & i).Resize(25, 5).Value Max_ro = ws2.Range("c:c"). _ Find(Application.Max(ws2.Range("c:c"))).Row first_row = IIf(i < 30, Max_ro + 10, Max_ro + 9) Next With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف ALL_In_one_sheet.xlsm

وعليكم السلام .... انظر المرفق ... New Microsoft Access قاعدة بيانات (6).accdb

هل هذا ما تريد ؟؟؟؟ Forum.mdb

هل هذه بداية الحل حتى نكمل بقية المطلوب ....... Forum.mdb

السلام عليكم 🙂 اللغة العربية هي المطلوبة هنا 🙂 المرفق المضغوط فيه مجلد وبرنامج اكسس ، والبرنامج اللي يعمل لنا 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

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

اضطراب في نتائج البحث.rar

جزاك الله خيرا اخي العزيز وتمت التجربة على سيرفر وشبكة مرتبط بها 13 مستخدم وشغال 100% عاشت ايدك😘

المزيد في هذا الملف حيث يتم ادراح مقاطع صفحات الطباعة (كل 25 اسم على لائحة منفردة) الكود Option Explicit Sub Give_Me_Printing_Data_Please() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim Data As Worksheet Dim ws2 As Worksheet Set Data = Sheets("data") Set ws2 = Sheets("Archive") Dim m%: m = 1 Dim Arr() Dim final_row With ws2 .Range("a38:j10000").ClearContents .Range("c10:j34").ClearContents End With Dim Capcity%, i%, k%, Max_ro% Dim ro%: ro = 39 Dim first_row%: first_row = 10 Dim lr_data% lr_data = Data.Application.Max(Data.Range("A:A")) Capcity = lr_data \ 25 If lr_data Mod Capcity > 0 Then Capcity = Capcity + 1 For k = 1 To Capcity - 1 ws2.Range("c5:j37").Copy ws2.Range("c" & ro) ro = ro + 33 Next For i = 6 To lr_data + 25 Step 25 ws2.Range("c" & first_row).Resize(25, 5).Value = _ Data.Range("a" & i).Resize(25, 5).Value Max_ro = ws2.Range("c:c"). _ Find(Application.Max(ws2.Range("c:c"))).Row first_row = IIf(i < 30, Max_ro + 10, Max_ro + 9) ReDim Preserve Arr(1 To m) Arr(m) = Max_ro + 3 m = m + 1 Next '=================================== With Sheets("Archive") final_row = ws2.Cells(Rows.Count, "E").End(3).Row Arr(UBound(Arr)) = final_row + 2 .PageSetup.PrintArea = .Range("c5:j" & final_row + 1).Address .ResetAllPageBreaks .VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 For k = 1 To UBound(Arr) - 1 If k = UBound(Arr) - 1 Then .HPageBreaks.Add Before:=.Cells(Arr(k) + 3, 1) Else .HPageBreaks.Add Before:=.Cells(Arr(k) + 1, 1) End If Next End With '================================ MsgBox "That is All" & Chr(10) & "You have " & Capcity & " Pages To Print" _ & Chr(10) & "Good Luck From Salim" With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With Erase Arr End Sub الملف من حديد Print_ALL_In_one_sheet.xlsm

استاذ سليم بارك الله فيك وحفظك الله.تقبل الله منا ومنكم صالح الاعمال

اتفضل الملف لعله يفى بالغرض نسخة من SH 1.xlsx

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

السلام عليكم ورحمة الله كل عام و انتم بخير اخى الكريم بمناسبة الشهر الفضيل و نهاية العام الدراسى اليك ماطلبت باذن الله و اى ملاحظات ستجدنى فى الموعد باذن الله ثانية.rar

الف الف شكر أستاذي الكريم بارك الله فيك وجعله في ميزان حسناتك ....

اتفضل الملف لعله يفى بالغرض نموذج العمل على القالب.xlsx

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

كل المحبة والاحترام

تسلم ايدك استاذ سليم حل روعة جزاكم الله خير

تسلم ايدك استاذنا الفاضل ممتازة جزاكم الله خير الجزاء

السلام عليكم الجواب : موجود داخل الملف استبدال قيم بقيم اخرى.xlsx

@MrTid @kha9009lid @عبد اللطيف سلوم @مسفر جربو الاختصار هذا Private Sub item1_AfterUpdate() Me.نص9.Visible = Not IsNull(item1) End Sub Private Sub item2_AfterUpdate() Me.نص11.Visible = Not IsNull(item2) End Sub تحياتي

@مسفر @qathi ولكن فكرة الاخ مسفر لن تستطيع التنقل بالتاب حتى لوكنت في بداية السجلات او في اي موقع خارج السجل الاخير تحياتي

استبدل في المعادلة الفاصلة ", " بفاصلة منقوطة "; " لتصبح بهذا الشكل ( حسب اعدادات الجهاز عندك) =IF(C2="";"";2*QUOTIENT(C2;100000))

في الخلية اكتب هذه المعادلة واسحب نزولاً =IF(C2="","",2*QUOTIENT(C2,100000))

بارك الله فيكم وجزاكم من فضله

نسخة من 0000-1.xlsm

جرب هذا الملف Zero_files.xlsm

لا أحد بستطيع التعامل مع صورة الرجاء تحميل الملف نفسه و فيه شرح لما تريد