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

السلام عليكم نظرا لبعض طلبات الاعضاء الكرام . خاصة ممن يقومون بعمل برامج من أجل كسب العيش أعانهم الله فيما يخص حماية الاكواد التي بملفاتهم لانه عادة ما تحصل سرقة لبرامجهم و هذا بسبب ان أكسل لا يوفر الخماية الكاملة اضافة الى أن هناك برامج تقوم بكشف كلمات سر الملف ببساطة. لذلك اردت أن أقدم فكرة و هي تحويل الكود البرمجي الى ملف DLL مما يوفر حماية قوية للملف عن طريق برنامج vbacompiler for excel و لكن للاسف غير مجاني و هو برنامج يقوم بتحويل الاكواد بالملف الى ملف DLL و تغيير الاكواد بالملف لتستدعى ملف DLL الذي تم انشاؤه و يعمل الملف بكفاءءة عالية لقد قمت بالتجريب و فعلا نتيجة رائعة. يمكنك تحميل البرنامج كنسخة تجريبية . و بالنسبة للذين يعملون البرامج و يبيعونها و يكسبون العيش مننها يمكنهم شراء النسخة الكاملة كيف تحمي ملفك ؟ يمكنك وضع كود خاص بكلمة السر و السريال نمبر للهارد ديسك و ييمكنك وضع الكود التالي عند فتح الملف WORK BOOK OPEN يعني اذاكان رقم السريال نمبر هو مثلا : FFFFF-FFFFF-FFFFF ادخل الرقم السري 222222 و اذا كان خطأا اغلق الملف Private Sub Workbook_Open() Dim RAD As String If CreateObject("Scripting.FileSystemObject").GetDrive("C:\").SerialNumber = "FFFFF-FFFFF-FFFFF" Then RAD = InputBox("Enter password:") If LCaseRAD <> "222222" Then ActiveWorkbook.Close False End If End Sub و بعد الانتهاء من عمل ملف افتح برنامج vbacompiler for excel و جول ملفك الى ملف جديد معه ملف DLL يمكنك التجريب على أي ملف لقد قمت بتجريب البرنامج على ملف أحد الاعضاء و النتيجة بالمرفقات الملف عبارة عن كود بسيط يبحث عن تكرار في عمودين و نقل المكرر الى عمود ثالث هدا الكود مثلا قبل استعمال برنامج vbacompiler for excel Sub brg() ScreenUpdating = False Dim lr As Integer Dim lr1 As Integer Dim c As Range lr1 = ActiveSheet.Range("g" & Rows.Count).End(xlUp).Row For Each c In ActiveSheet.Range("c2:c1000") lr = ActiveSheet.Range("i" & Rows.Count).End(xlUp).Row If WorksheetFunction.CountIf(ActiveSheet.Range("g2:g" & lr1), c.Value) >= 1 Then Cells(lr + 1, 9) = c.Value On Error Resume Next End If Next ScreenUpdating = True End Sub و هذا بعد استعمال البرنامج #If Win64 Then Private Declare PtrSafe Sub p0iflwmc269 Lib "EXEMPLE_xlsm_64.dll" Alias "r8rfyae98n05rlq" () #Else Private Declare Sub p0iflwmc269 Lib "EXEMPLE_xlsm_64.dll" Alias "r8rfyae98n05rlq@0" () #End If Sub brg() p0iflwmc269 End Sub Option Private Module #If Win64 Then Private Declare PtrSafe Function SetThisWbk Lib "EXEMPLE_xlsm_64.dll" Alias "SetThisWorkbook" (ByVal twbk As Object) As Long Private Declare PtrSafe Function u6hpyov9dx5 Lib "EXEMPLE_xlsm_64.dll" (ByVal i As Long, ByVal obj As Object) As Long Private Declare PtrSafe Function c1smc91ey1mls Lib "EXEMPLE_xlsm_64.dll" (ByVal i As Long, ByVal mp As LongPtr) As Long Private Declare PtrSafe Function s1a3nzo1yqora3l Lib "EXEMPLE_xlsm_64.dll" () As Variant Private Declare PtrSafe Sub d0np2x0oglsn Lib "EXEMPLE_xlsm_64.dll" (ByVal dst As Any, ByVal src As LongPtr, ByVal sz As Long) Private Declare PtrSafe Function p8t9c8qi9tgx Lib "EXEMPLE_xlsm_64.dll" (ByRef p() As Any) As LongPtr Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal libFileName As String) As LongPtr Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As LongLong Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr #Else Private Declare Function SetThisWbk Lib "EXEMPLE_xlsm_64.dll" Alias "SetThisWorkbook@4" (ByVal twbk As Object) As Long Private Declare Function u6hpyov9dx5 Lib "EXEMPLE_xlsm_64.dll" Alias "u6hpyov9dx5@8" (ByVal i As Long,ByVal obj As Object) As Long Private Declare Function c1smc91ey1mls Lib "EXEMPLE_xlsm_64.dll" Alias "c1smc91ey1mls@8" (ByVal i As Long,ByVal mp As Long) As Long Private Declare Function s1a3nzo1yqora3l Lib "EXEMPLE_xlsm_64.dll" Alias "s1a3nzo1yqora3l@0" () As Variant Private Declare Sub d0np2x0oglsn Lib "EXEMPLE_xlsm_64.dll" Alias "d0np2x0oglsn@12" (ByVal dst As Any,ByVal src As Long,ByVal sz As Long) Private Declare Function p8t9c8qi9tgx Lib "EXEMPLE_xlsm_64.dll" Alias "p8t9c8qi9tgx@4" (ByRef p() As Any) As Long Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal libFileName As String) As Long Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long #End If Private Function k7wgf46mba0cj8() As String On Error Resume Next k7wgf46mba0cj8 = ThisWorkbook.Path + "\EXEMPLE_xlsm_64.dll" End Function Public Sub p8oi75y3jrid8() #If Win64 Then Dim hModule As LongPtr Dim dllPath As String Dim msg As String On Error Resume Next dllPath = k7wgf46mba0cj8() hModule = LoadLibrary(dllPath) If hModule = 0 Then MsgBox "Cannot load '" & dllPath & "'" ThisWorkbook.Close False Else c1smc91ey1mls 1&, AddressOf u4fw2npwzdn25f4 If SetThisWbk(ThisWorkbook) Then u6hpyov9dx5 3&, Sheet1 u6hpyov9dx5 4&, Sheet2 u6hpyov9dx5 2&, ThisWorkbook ThisWorkbook.Saved = True Else GoTo qpnt End If End If #Else MsgBox "This workbook can work with 64 bit Excel only" ThisWorkbook.Close False #End If Exit Sub qpnt: ThisWorkbook.Close False End Sub Public Sub x1u5slqd9g() On Error GoTo errh SetThisWbk (ThisWorkbook) Exit Sub errh: p8oi75y3jrid8 End Sub Public Function q7uobay8mw() As Boolean On Error Resume Next q7uobay8mw = GetModuleHandle("EXEMPLE_xlsm_64.dll") <> 0& End Function #If Win64 Then Public Function FreeCompiledDll() As LongLong Dim i As Long Do FreeCompiledDll = FreeLibrary(GetModuleHandle("EXEMPLE_xlsm_64.dll")) i = i + 1 Loop While FreeCompiledDll <> 0 And i < 100 End Function #End If Private Sub auto_open() x1u5slqd9g End Sub Private Sub auto_close() #If Win64 Then On Error Resume Next Dim p As Variant ThisWorkbook.Saved = True SetThisWbk Nothing p = s1a3nzo1yqora3l FreeCompiledDll If p <> "" Then Kill p & "cbinrtl.dll" RmDir p End If #End If End Sub Function u4fw2npwzdn25f4(ByVal v7liriqd8 As Variant, ByVal m8g6onrhcrw As Variant, ByVal m7jy4oel As Variant, ByRef j8yhrsbf2() As Variant) As Variant On Error Resume Next Dim sz As Long sz = UBound(j8yhrsbf2) - LBound(j8yhrsbf2) + 1 Select Case sz Case 0 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel) Case 1 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0)) Case 2 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1)) Case 3 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2)) Case 4 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3)) Case 5 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4)) Case 6 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5)) Case 7 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6)) Case 8 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6), j8yhrsbf2(7)) Case 9 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6), j8yhrsbf2(7), j8yhrsbf2(8)) Case 10 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6), j8yhrsbf2(7), j8yhrsbf2(8), j8yhrsbf2(9)) End Select End Function و الملف يعمل بكفاءة جيدة يمكنكم التجربة من المرفقات ملف خاص بعد التشفير ب اوفيس 64 و ملف خاص بعد التشفير ب اوفيس 32 و السلام عليكم و تقبل الله منا و منكم الملف بدون تشفير.rar الملف مشفر مع ملف DLL لنسخة اوفيس 32.rar الملف مشفر مع ملف DLL لنسخة اوفيس 64.rar

ضع هذا الكود في حدث عند النقر Dim a, s As String s = Me.eee.Column(0) a = "Table." & s Me.fff.SourceObject = a

استخدم هذا الكود B.SetFocus Form!B!c.SetFocus

[B]![C].SetFocus

وعليكم السلام ورحمة الله وبركاته لانك تقوم باغلاق نموذج Fz_1 وذلك في الامر التالي DoCmd.Close Private Sub b2_Click() TimerId = SetTimer(0, 0, 1, AddressOf TimerProc) str_Title = "الرقم السري مطلوب" str_Prompt = "ادخل الرقم السري" If InputBox(str_Prompt, str_Title) = "123" Then MsgBox "الرقم السري صحيح", , "تفضل بالدخول" DoCmd.Close DoCmd.OpenForm "Fz_12", acNormal Else MsgBox "الرقم السري خاطىء", , "لا يمكنك الدخول" Exit Sub End If End Sub والافضل استبدال امر الاغلاق بامر اخفاء كالتالي Me.Visible = False واليك الكود كاملاً Private Sub b2_Click() TimerId = SetTimer(0, 0, 1, AddressOf TimerProc) str_Title = "الرقم السري مطلوب" str_Prompt = "ادخل الرقم السري" If InputBox(str_Prompt, str_Title) = "123" Then MsgBox "الرقم السري صحيح", , "تفضل بالدخول" ' DoCmd.Close Me.Visible = False DoCmd.OpenForm "Fz_12", acNormal Else MsgBox "الرقم السري خاطىء", , "لا يمكنك الدخول" Exit Sub End If End Sub 1_2.rar تحياتي

وعليكم السلام اخى @ازهر عبد العزيز هل تريد عرض القيمه المختاره من الكمبو فى حق نص فالتقرير ام ماذا ؟ اذا كان كذلك ضع مربع نص بالتقرير وفى مصدر عنصر التحكم =[Forms]![FYXY]![اسم الكمبو بالنموذج]

هلا اخي هذه السلسلة مميزة

اخي مصطفى تفضل على حسب ما فهمت رغم انه الشرح غامض يجب عليك كتابة الشهر في الخلية a2 =IFERROR(SUMPRODUCT(('2020'!$B$4:$B$6000=$A8)*(TEXT('2020'!$D$4:$D$6000&"-"&'2020'!$E$4:$E$6000;"YYYYMM")<=TEXT($A$2&"-"&D$6;"YYYYMM"));'2020'!$F$4:$F$6000);"") MMM1.xlsx

بعد اذن الاخ رائد هذا الملف تم حماية العادلات لعدم التلاعب بها غن طريق الخطأ My_Book5.xlsx

تم معالجة الامر Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$4" And Target.Count = 1 Then Tranfer_data End If Application.EnableEvents = True End Sub '////////////////////////////////////////////// Sub Tranfer_data() Application.EnableEvents = False Dim R As Worksheet, A As Worksheet, K As Worksheet Dim start_Ro%, i%, m% Dim Start_date As Date, End_date As Date, mot$ Dim x As Boolean, y As Boolean, z As Boolean, t As Byte Dim KRg, Fixrow%, Actrow%, Find_rg As Range, Spec_Rg As Range Dim SF#, SG#, ALLROW% Set R = Sheets("repo"): Set A = Sheets("Achat") Set K = Sheets("Kazina") K.Range("B3").CurrentRegion.Interior.ColorIndex = xlNone Start_date = R.Range("B2"): End_date = R.Range("B3"): mot = R.Range("B4") If R.Range("A8").CurrentRegion.Rows.Count > 1 Then _ R.Range("A8").CurrentRegion.Offset(1). _ Resize(R.Range("A8").CurrentRegion.Rows.Count - 1).Clear i = 5: start_Ro = 9 Do Until A.Range("B" & i) = vbNullString x = A.Range("B" & i) = mot: y = A.Range("D" & i) >= Start_date z = A.Range("D" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 10).Value = _ A.Cells(i, 2).Resize(, 10).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop i = 5 Set Find_rg = K.Range("B3").CurrentRegion.Columns(3) Set Spec_Rg = Find_rg.Find(mot, lookat:=1) If Not Spec_Rg Is Nothing Then Fixrow = Spec_Rg.Row: Actrow = Fixrow i = 9: m = 9 Do '================================== y = K.Cells(Actrow, "C") >= Start_date z = K.Cells(Actrow, "C") <= End_date t = Abs(y * z) If t Then R.Cells(m, "C") = _ IIf(IsDate(K.Cells(Actrow, "C")), K.Cells(Actrow, "C"), "") R.Cells(m, "K") = _ IIf(IsNumeric(K.Cells(Actrow, "G")), K.Cells(Actrow, "G"), "") K.Cells(Actrow, 2).Resize(, 7).Interior.ColorIndex = 40 m = m + 1 End If Set Spec_Rg = Find_rg.FindNext(Spec_Rg) Actrow = Spec_Rg.Row i = i + 1 Loop Until Fixrow = Actrow ALLROW = R.Range("A8").CurrentRegion.Rows.Count + 8 '++++++++++++++++++++++++++++++++++++++++++ ' R.Cells(ALLROW, "K") = "المجموع" ' R.Cells(ALLROW, "L") = _ ' Evaluate("=SUM(L9:L" & ALLROW - 1 & ")") '++++++++++++++++++++++++++++++++++++++++++ End If Set Spec_Rg = R.Range("A8").CurrentRegion If Spec_Rg.Rows.Count = 1 Then GoTo End_Me Set Spec_Rg = Spec_Rg.Offset(1).Resize(Spec_Rg.Rows.Count - 1) Set Spec_Rg = Spec_Rg.SpecialCells(2) With Spec_Rg .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 40 End With R.Range("A8").CurrentRegion.Columns(3).NumberFormat = "[$-ar-LB] dddd d mmmm yyyy" R.Range("A8").CurrentRegion.Sort key1:=R.Cells(1, 3), Header:=1 End_Me: Application.EnableEvents = True ' '++++++++++++++++++++++++++++++++++++++ End Sub الملف الرابع مرفق SAL_My_data_4.xlsm

تفضل Book5.xlsx

الافضل بالنسبةلي على الاطلاق INNO SETUP Key features: Support for every Windows release since 2006, including: Windows 10, Windows 10 on ARM, Windows Server 2019, Windows Server 2016, Windows 8.1, Windows 8, Windows Server 2012, Windows 7, Windows Server 2008 R2, Windows Server 2008, and Windows Vista. (No service packs are required.) Extensive support for installation of 64-bit applications on the 64-bit editions of Windows. The x64, ARM64 and Itanium architectures are all supported. Extensive support for both administrative and non administrative installations. Supports creation of a single EXE to install your program for easy online distribution. Disk spanning is also supported. Standard Windows wizard interface. Customizable setup types, e.g. Full, Minimal, Custom. Complete uninstall capabilities. Installation of files: Includes integrated support for "deflate", bzip2, and 7-Zip LZMA/LZMA2 file compression. The installer has the ability to compare file version info, replace in-use files, use shared file counting, register DLL/OCX's and type libraries, and install fonts. Creation of shortcuts anywhere, including in the Start Menu and on the desktop. Creation of registry and .INI entries. Running other programs before, during or after install. Support for multilingual installs, including right-to-left language support. Support for passworded and encrypted installs. Support for digitally signed installs and uninstalls, including dual signing (SHA1 & SHA256). Silent install and uninstall. Unicode installs. Integrated preprocessor option for advanced compile-time customization. Integrated Pascal scripting engine option for advanced run-time install and uninstall customization. Full source code is available from GitHub. Tiny footprint: only about 1.3 mB overhead with all features included. All features are fully documented. Used by Microsoft Visual Studio Code and Embarcardero Delphi. Is it really free of charge, even for commercial use? https://jrsoftware.org/isdl.php

كل عام وحضراتكم بخير ورمضان كريم اعاده الله عليكم وعلى الامة الاسلامية بالخير واليمن البركات البحث فى القرآن الكريم.xlsm

شكرا علي هذه المعلومة افادك الله وانشاء الله موقع ( أوفيسنا ) في تقدم وازدهار ديماً بأحتواء ألاعضاء بفضل ( معلميها وخبراءها ) وفعلاً أثبت هذا المنتدي أنه منارة تعليمية . والله الموفق

لا يوجد خطأ نموذج الاقساط لديك مصدر بياناته استعلام يحتوى على معيار [Forms]![العملاء]![كود العميل] وهذا المعيار مبني على حقل كود العميل من نموذج العملاء وبالتالي عند فتح النموذج الاقساط مباشرة ونموذج العملاء مغلق تظهر الرسالة التي تطلب كود العميل ويحصل عندك عبارة خطاء في كود العميل واسمة وكذلك حقل المتبقي

وعليكم السلام ورحمة الله وبركاته في البداية لا يجب ان يكون لديك في جدول ( جدول الكتب ) حقل لكل كتاب ( كتاب1 ، كتاب2 ،كتاب3 ، .... الخ ) يكفي ان تضع حقل اسم الكتاب فقط انظر جدول ( جدول الكتب ) ثم نقوم بانشاء جدول ( جدول توزيع الكتب ) ثم تقوم باضافة حقول ( رقم الطالب - رقم الكتاب ) حتى تعرف فيما بعد من الطلاب الذين تم توزيع الكتب عليهم ثم تقوم بربط حقل رقم الطالب من جدول ( الطلاب ) بحقل رقم الطالب في جدول ( جدول توزيع الكتب ) وربط حقل ( رقم الكتاب ) من جدول ( جدول الكتب ) بحق ( رقم الكتاب ) في جدول ( جدول توزيع الكتب ) انظر العلاقة بين الجداول ثم تنشىء استعلام به البيانات اللازمة لمعرفة الكتب التي تم توزيعها على الطلاب انظر استعلام Query1 وعدل عليه بما يناسبك ثم انشىء تقرير مبني على الاستعلام Query1 وسيعرض على النتائج مضبوطة ان شاء الله وذلك بعمل معيار او بعمل تصفية حسب النموذج سجل - .rar تحياتي

بخصوص تكرار الاقساط لانك لم تضع شرط في الميكرو الاقساط.accdb

هلا اخي جرب المرفق test.accdb

بارك الله فيك استاذنا رائد احترامى

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

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

تفضل

ضع الكود في حدث this workbook Private Sub Workbook_Open() Dim c As Range For Each c In Range("c2:c4") c.Formula = "=TickerChart|Live!'QO." & c.Offset(, -2).Value & ".TAD$lasttradeprice'" Next c Dim d As Range For Each d In Range("d2:d4") d.Formula = "=TickerChart|Live!'QO." & d.Offset(, -3).Value & ".TAD$lasttradeprice'" Next d Dim e As Range For Each e In Range("e2:e4") e.Formula = "=TickerChart|Live!'QO." & e.Offset(, -4).Value & ".TAD$lasttradeprice'" Next e End Sub 9.xlsm

أستاذ صالح ربيع أين الضغط على الإعجاب لهذه الإجابة الممتازة ؟!!💙 وهذا اقل ما يقدم لمن له الفضل بعد ربنا فى حل مشكلتك

مشاركة مع الاخ الفاضل يمكنك ايضا بعد مشاهدة ما اشار اليه الاستاذ / محب العقيدة ان تشاهد التالى https://www.youtube.com/watch?v=8ghsbRvIv5U&t=626s فهو باللغة العربية ـ مع انى لا احب هذه الطرق

جزاك الله كل خير وبارك الله فيك

أحسنت اخى الكريم عمل رائع بارك الله فيك وزادك الله من فضله

وعليكم السلام -كان هناك خطأ بالمعادلة وتم تصحيحه -تفضل وهو انك قمت بتعديل وتغيير أعمدة مصدر جلب البيانات بالمعادلة -لاحظ الفرق بنفسك Std_7.xlsx

Mostafa Moawad أين الضغط على الإعجاب لهذه الإجابة الممتازة ؟!!!💙

https://m.youtube.com/watch?v=RCEDeiHo0bg&list=PL74DkfdscvwRv6lwrU5ZkY0y43gyUsykS&index=50&t=0s انظر لكن بالفرنسي قناة فد واستفد وهي مفيدة جدا انصح كل من يريد الاحتراف آن يتابعها حتى بالصورة فقط ينظر الى الاكواد

اخي العزيز المواد الدراسية لا تضاف الى الفورم وانما تكتب في كود تعيين مواد. ادخل على محرر الاكواد اختر MODULE18تجد كود باسم تغيين مواد تجد به اسماء المواد حسب الصفوف غير اسماء المواد بالكود ثم اغلق الملف بالجفظ ثم افتح الملف تجد ما كتبته من مواد . قمت بكتابة 3مواد وقم انت بالباقي اتمنى انى قدمت لك ما يفيدك وان لم يتضح لك شئ لا تخجل في طلبه تحياتي اضافة مواد.rar

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

جرب ان تذهب لخصائص الجدول وهو في حالة عرض التصميم وامسح الخاصية مابداخل الصندوق الاحمر بالتوفيق

الاستاذ المبدع ابو تراب شكرا جزيلا لك

تم التعديل Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$4" And Target.Count = 1 Then Tranfer_data End If Application.EnableEvents = True End Sub '////////////////////////////////////////////// Sub Tranfer_data() Application.EnableEvents = False Dim R As Worksheet, A As Worksheet, K As Worksheet Dim start_Ro%, i%, m% Dim Start_date As Date, End_date As Date, mot$ Dim x As Boolean, y As Boolean, z As Boolean, t As Byte Dim KRg, Fixrow%, Actrow%, Find_rg As Range, Spec_Rg As Range Dim SF#, SG#, ALLROW% Set R = Sheets("repo"): Set A = Sheets("Achat") Set K = Sheets("Kazina") K.Range("B3").CurrentRegion.Interior.ColorIndex = xlNone Start_date = R.Range("B2"): End_date = R.Range("B3"): mot = R.Range("B4") If R.Range("A8").CurrentRegion.Rows.Count > 1 Then _ R.Range("A8").CurrentRegion.Offset(1). _ Resize(R.Range("A8").CurrentRegion.Rows.Count - 1).Clear i = 5: start_Ro = 9 Do Until A.Range("B" & i) = vbNullString x = A.Range("B" & i) = mot: y = A.Range("D" & i) >= Start_date z = A.Range("D" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 10).Value = _ A.Cells(i, 2).Resize(, 10).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop i = 5 Set Find_rg = K.Range("B3").CurrentRegion.Columns(3) Set Spec_Rg = Find_rg.Find(mot, lookat:=1) If Not Spec_Rg Is Nothing Then Fixrow = Spec_Rg.Row: Actrow = Fixrow i = 9: m = 9 Do '================================== y = K.Cells(Actrow, "C") >= Start_date z = K.Cells(Actrow, "C") <= End_date t = Abs(y * z) If t Then R.Cells(m, "k") = _ IIf(IsDate(K.Cells(Actrow, "C")), K.Cells(Actrow, "C"), "") R.Cells(m, "k").NumberFormat = "[$-ar-LB] dddd d mmmm yyyy" R.Cells(m, "L") = _ IIf(IsNumeric(K.Cells(Actrow, "G")), K.Cells(Actrow, "G"), "") K.Cells(Actrow, 2).Resize(, 7).Interior.ColorIndex = 40 m = m + 1 End If Set Spec_Rg = Find_rg.FindNext(Spec_Rg) Actrow = Spec_Rg.Row i = i + 1 Loop Until Fixrow = Actrow ALLROW = R.Range("A8").CurrentRegion.Rows.Count + 8 '++++++++++++++++++++++++++++++++++++++++++ R.Cells(ALLROW, "K") = "المجموع" R.Cells(ALLROW, "L") = _ Evaluate("=SUM(L9:L" & ALLROW - 1 & ")") '++++++++++++++++++++++++++++++++++++++++++ End If Set Spec_Rg = R.Range("A8").CurrentRegion If Spec_Rg.Rows.Count = 1 Then GoTo End_Me Set Spec_Rg = Spec_Rg.Offset(1).Resize(Spec_Rg.Rows.Count - 1) Set Spec_Rg = Spec_Rg.SpecialCells(2) With Spec_Rg .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 40 End With End_Me: Application.EnableEvents = True ' '++++++++++++++++++++++++++++++++++++++ End Sub الملف مرفق SAL_My_data_3.xlsm

هذا البرنامج يقوم بما طلبت وهو معرب simsetup.rar

ماذا تقصد بملف تنفيذي .. تقصد ملف بامتداد exe. افضل شي هو برنامج ضغط الملفات rar ابحث عن شرح فيديو لتحويل ملف الاكسس الي .exe باستخدام برنامج ضغط الملفات rar تحياتي 🌹

اخي الكريم جزاك الله خيرا لازم ترفع نمودج لملف العمل تحياتي

امين يارب العالمين وجزاكم الله خير استاذ هلال ودعوتكم معنا وان شاء الله نكون عند حسن ظنكم استاذ مجدى

استاذ عبد اللطيف اسمح لي قمت باجراء تعديل بسيط عند تنفيذ الاقساط بحيث اذا كان القسط منفذ تظهر رسالة ان الاقساط مجدولة ويلغى الامر واذا لم تكن مجدولة يتم التنفيذ اقساط.accdb

بالنسبة لمرفق الاستاذ محمد فهو يستحق عنوان وموضوع يخصه اخي اواب اعتذر عن التأخير والمسألة غلطة مطبعية او بالاصح تقديم سطر على سطر في الحدث Sub zerNc() انقل Exit Sub واجعلها في نهاية الاسطر يعني تكون بعد السطر Call delfiles كان الخلل انه يعطي نسخة ثم يخرج من الحدث قبل امر الحذف