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

السلام عليكم في احد مشاريعي ، جابوا لي قائمة اكسل فيها تواريخ مكتوبة بكل ما لذ وطاب من الطرق ، مثل: 30/11/2009 ، 2012-06-25 ، 21/6/2015م ، " 9/1/2014" ، 30\11\2009 ، 5/1999/26 ، 25/1999/6 ، 5/1994/ 26 ، وحتى بعضها بالارقام الهندية ، فعملت الدالة التالية ، والتي ترسل لها التاريخ المطلوب تعديله ، والدالة تصلح التاريخ وترجعه. وستلاحظون اني استخدمت الدالة DateSerial ، حتى اعطي اليوم والشهر والسنة بياناتهم يدويا ، بدلا عن استعمال CDate . هذه هي الدالة: Function Date_Rectified(D As String) As Date On Error Resume Next Dim x() As String Dim P1 As String, P2 As String, P3 As String D = Trim(D) D = Replace(D, "(", "") D = Replace(D, ")", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, "*", "") D = Replace(D, "م", "") D = Replace(D, ChrW(1632), "0") 'الرقم الهندي صفر D = Replace(D, ChrW(1633), "1") D = Replace(D, ChrW(1634), "2") D = Replace(D, ChrW(1635), "3") D = Replace(D, ChrW(1636), "4") D = Replace(D, ChrW(1637), "5") D = Replace(D, ChrW(1638), "6") D = Replace(D, ChrW(1639), "7") D = Replace(D, ChrW(1640), "8") D = Replace(D, ChrW(1641), "9") D = Replace(D, "!", "-") D = Replace(D, "/", "-") D = Replace(D, "//", "-") D = Replace(D, "\", "-") D = Replace(D, ".", "-") D = Replace(D, "_", "-") D = Replace(D, "|", "-") D = Replace(D, ",", "-") D = Replace(D, Chr(34), "") If Len(D) = 4 Then 'starts with year, but its 4 digits only:1999 'convert to 1-1-1999 OR EMPTY Date_Rectified = DateSerial(D, 1, 1) Exit Function End If If D = "5/1994/ 26" Then Debug.Print D End If x = Split(D, "-") P1 = x(0): P2 = x(1): P3 = x(2) If Len(P1) = 4 And Len(P2) <> 0 Then 'starts with year, and month exist: 1999-1-2 Date_Rectified = DateSerial(P1, P2, P3) ElseIf Len(P3) = 4 And Len(P2) <> 0 Then 'ends with year, and month exist: 2-1-1999 Date_Rectified = DateSerial(P3, P2, P1) ElseIf Len(P2) = 4 And Len(P1) <= 12 Then 'year in the middle, day and month exist: 5/1999/26 Date_Rectified = DateSerial(P2, P1, P3) ElseIf Len(P2) = 4 And Len(P1) > 12 Then 'year in the middle, day and month exist: 25/1999/6 Date_Rectified = DateSerial(P2, P3, P1) Else 'otherwise Date_Rectified = Null End If End Function

السلام عليكم ورحمة الله وبركاته.. كنت اعمل على مشروع للقرآن الكريم، يكون ضمن تطبيق قوت القلوب، صورته في التوقيع 🥰 البرنامج من تصميمي وبرمجتي 100% فاحتجت للقرآن الكريم مرتل ومقسم لايات قمت بالعثور على ختمات كاملة وللعديد من القرآء في موقع Archive.org فقمت بتحويل الروابط الى قاعدة بيانات SQLite تتضمن ترتيل القرآن الكريم على شكل ايات كل آية على حدا وبرابط مباشر، أي ستقوم بتشغيل الصوت من الرابط مباشرة بدون تنزيلة طبعا يمكنكم تشغيل الصوت مباشرة من الويب باستخدام الكثير من المكتبات المجانية مثل NAudio.dll وغيرها... قبل كل شيء، هذا الكود لإنشاء الجدول sounds الذي ستكون فيه روابط الصوت لايات القرآن الكريم في قاعدة البيانات.. 1. تسلسل السورة 2. رقم الآية 3. رابط الملف الصوتي للآية 4. معرف القارئ CREATE TABLE "sounds" ( "surah_number" INTEGER, "ayah_number" INTEGER, "audio_url" TEXT, "reader_id" INTEGER ); 0. احمد نعينع 1. الطبلاوي 2. عبد الباسط 3. المنشاوي 4. الحصري السورس كود للفائدة، الذي يقوم بتوليد الايات حسب السور بلغة NET. Sub GenerateQuranAudioLinks(ByVal baseUrl As String, ByVal reader_id As String) ' عدد الآيات لكل سورة من القرآن الكريم Dim surahAyatCounts As Integer() = { 7, 286, 200, 176, 120, 165, 206, 75, 129, 109, 123, 111, 43, 52, 99, 128, 111, 110, 98, 135, 112, 78, 118, 64, 77, 227, 93, 88, 69, 60, 34, 30, 73, 54, 45, 83, 182, 88, 75, 85, 54, 53, 89, 59, 37, 35, 38, 29, 18, 45, 60, 49, 62, 55, 78, 96, 29, 22, 24, 13, 14, 11, 11, 18, 12, 12, 30, 52, 52, 44, 28, 28, 20, 56, 40, 31, 50, 40, 46, 42, 29, 19, 36, 25, 22, 17, 19, 26, 30, 20, 15, 21, 11, 8, 8, 19, 5, 8, 8, 11, 11, 8, 3, 9, 5, 4, 7, 3, 6, 3, 5, 4, 5, 6 } ' حلقة لتوليد جمل SQL لكل سورة وآياتها For surah As Integer = 1 To 114 Dim surahNumber As String = surah.ToString("D3") ' تحويل رقم السورة إلى 3 أرقام Dim ayatCount As Integer = surahAyatCounts(surah - 1) ' توليد جمل SQL بناءً على عدد الآيات لكل سورة For ayah As Integer = 0 To ayatCount Dim ayahNumber As String = ayah.ToString("D3") ' تحويل رقم الآية إلى 3 أرقام Dim fileUrl As String = baseUrl & surahNumber & ".zip" & "/" & surahNumber & ayahNumber & ".mp3" Dim sqlInsert As String = "INSERT INTO sounds (surah_number, ayah_number, audio_url, reader_id) VALUES (" & surah & "," & ayah & "," & "'" & fileUrl & "'" & "," & reader_id & ");" My.Computer.FileSystem.WriteAllText(Application.StartupPath & "\sql_" & reader_id & ".txt", sqlInsert & vbNewLine, True) Next Next '' تشغيل كل عملية في ثريد منفصل باستخدام Task 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/128kb---a7mad--n3ena3---morattal------quran----6236---ayaat-----__verse--by---_189/", "1")) 'احمد نعينع 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/64kb__---mp3------------quran----6236---ayaat-----__verse--by---verse----_-by-/", "2")) 'الطبلاوي 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/192kb----morattal----quran----6236---ayaat-----__verse--by---verse----_-by--ab_525/", "3")) 'عبد الباسط 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/128kb____--mp3-------full-----quran----6236---ayaat-----__verse--by---verse---/", "4")) 'المنشاوي 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/64kb___--mp3-----quran----6236---ayaat-----__verse--by---verse----_-by---alhos/", "5")) 'الحصري End Sub ارفقت لكم البيانات على شكل ملفات TXT لكي تعدلو عليها كيفما شئتم. لا تنسوني ووالدي من صالح دعائكم SQLite.zip

وعليكم السلام ورحمة الله وبركاته الكود Sub ExtractAbsentees() Dim ws As Worksheet Dim lastRow As Long, lastCol As Long Dim i As Long, j As Long Dim outputRow As Long Set ws = ThisWorkbook.Sheets("SHEET1") lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row lastCol = ws.Cells(4, ws.Columns.Count).End(xlToLeft).Column outputRow = 5 For i = 5 To lastRow For j = 4 To lastCol If ws.Cells(i, j).Value = "A" Then ws.Cells(outputRow, 15).Value = ws.Cells(i, 2).Value ws.Cells(outputRow, 16).Value = ws.Cells(4, j).Value outputRow = outputRow + 1 End If Next j Next i End Sub الملف الغياب.xlsb

بداية يجب تفعيل هذه المكتبات لديك ..... KAN-picutre.rar

اعرض الملف ✨نصوص متحركة ✨ .. 4 أربعة أشكال متنوعة مما لذ وطاب 😊👌 السلام عليكم ورحمة الله وبركاته 🙂 هذي من بعض التجارب على عمل أشكال جديدة على النصوص المتحركة .. وقد خلصت التجارب إلى التالي 🙂 للاستفادة من المثال : لدينا أربعة نماذج ، كل واحد منها يحتوي على أحد الأشكال الموضحة بالترتيب .. قم بفتح النموذج المراد تطبيقه ثم أنقل الأكواد مثل ما هي إلى برنامجك + الليبل الموجود في النموذج ( ويمكنك أستخدام الليبل الخاص بك ) قم فقط بتعديل النص المراد تحريكة + اسم الليبل الذي سيتحرك النص بداخله . صاحب الملف Moosak تمت الاضافه 03 أكت, 2024 الاقسام قسم الأكسيس  

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

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) هذه المرة دعوة لتجربة لعبة المتاهة Maze لأول مرة من خلال آكسيس ميزات اللعبة :- التحكم الكامل من خلال الأسهم في لوحة المفاتيح . تجميع النقاط كلما التهمت الشخصية عدداً أكبر من ( ) . تخسر إذا لامست هذا الكائن في اللعبة ( ) عند طلب المساعدة باستخدام ( ) فإنه سيتم خصم 10 نقاط من رصيد النقاط التي قمت بتجميعها . اللعبة في إصدارها الأول حالياً وسيكون قريباً الكثير من المستويات في اللعب ، وهذه فقط دعوة لتجربتها وإفادتي بآرائكم حول تطويرها وتحديثها وأترككم مع ملف التحميل : Maze Game.zip

تفضلي : التحكم بالمسافة بين السطور في التقرير.accdb

ده بسبب انه حقل متعدد القيم ولا يمكن استخدام like مباشرتا ولهذا يجب اضافة Value الى اسم الحقل [grade] انظر للسطر التالي StrWhere = StrWhere & " and [grade].Value like '*" & Me.tx1 & "*'"

بعد اذن استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @jjafferr فعلا الموضوع مهم وملح جدا جدا لمن يقع فى هذه الورطة خاصة مع كثرة عدد السجلات التى تحتوى على صيغ تواريخ مختلفة وبالاخص لو كانت بها مشاكل اثراء للموضوع صادفنى هذه المشكلة ذات مرة فى العمل وهذه هى الوظيفة التى قمت بكتابتها للتعامل مع مختلف الصيغ والتسيقات حسب المشاكل التى واجهتها آن ذاك Function RectifyDateFormat(inputString As String) As Variant ' Enable error handling ' This line sets up an error handling routine. If an error occurs in the code that follows, ' execution will jump to the ErrorHandler label, allowing for controlled error management. On Error GoTo ErrorHandler ' Remove leading and trailing spaces ' This line uses the Trim function to eliminate any spaces at the beginning and end of the input string. ' This is important for ensuring that the date format is clean and free of unnecessary spaces ' which could lead to incorrect parsing of date parts later in the function. inputString = Trim(inputString) ' Replace Indian numerals with standard numerals ' This block replaces Indian numerals (Unicode character codes from 1632 to 1641) with standard Arabic numerals (0-9). ' The loop iterates through the Unicode range for Indian numerals and replaces each occurrence ' in the input string with its equivalent standard numeral by calculating its index. Dim i As Integer For i = 1632 To 1641 inputString = Replace(inputString, ChrW(i), CStr(i - 1632)) Next i ' Replace non-standard symbols with hyphens ' This section defines an array of symbols that are considered non-standard for date formatting. ' The goal is to standardize the date input by replacing these symbols with hyphens, ' making it easier to parse the date parts later on. Dim SymbolsToRemove As Variant SymbolsToRemove = Array("(", ")", "?", "*", " ", "!", "\", "/", "//", ".", "_", "--", "|", ",", Chr(227), Chr(34)) inputString = ReplaceSymbols(inputString, SymbolsToRemove) ' Remove leading and trailing hyphens ' This line first replaces any occurrence of double hyphens (--) with a single hyphen (-). ' After replacing, Trim is used to remove any spaces around the string. ' This ensures that any malformed input resulting in multiple hyphens is corrected before further processing. inputString = CleanHyphens(inputString) ' Split the input string into date parts ' This line splits the cleaned input string into an array of date parts using the hyphen (-) as a delimiter. ' The result is stored in strDateParts, which will contain the individual components of the date (day, month, year). Dim strDateParts() As String strDateParts = Split(inputString, "-") ' Ensure the input contains exactly three parts ' This condition checks if the upper bound of the strDateParts array is not equal to 2. ' In VBA, the array index starts from 0, so an array with exactly three elements will have ' an upper bound of 2 (i.e., elements at index 0, 1, and 2). ' If the input does not contain exactly three parts, the function returns Null ' to indicate an invalid date format, and exits the function to prevent further processing. If UBound(strDateParts) <> 2 Then RectifyDateFormat = Null Exit Function End If ' Assign the split parts to variables, ensuring they are trimmed ' This line assigns the individual parts of the date from the strDateParts array ' to three separate variables (strPartOne, strPartTwo, strPartThree). ' The Trim function is used to remove any leading or trailing whitespace from each part. ' This ensures that any extra spaces do not affect the subsequent processing of date parts. Dim strPartOne As String, strPartTwo As String, strPartThree As String strPartOne = Trim(strDateParts(0)): strPartTwo = Trim(strDateParts(1)): strPartThree = Trim(strDateParts(2)) ' Debug output for each part ' This line outputs the individual parts of the date to the immediate window for debugging purposes. ' Debug.Print "Part One: " & strPartOne & " | Part Two: " & strPartTwo & " | Part Three: " & strPartThree ' Ensure that the parts can be converted to numbers ' This conditional statement checks if each of the date parts (strPartOne, strPartTwo, strPartThree) ' can be converted to a numeric value. It uses the IsNumeric function to evaluate whether ' each part is a valid number. If any of the parts cannot be converted to a number, it indicates ' an invalid date format. In this case, the function returns Null to signify that the input is not a valid date, ' and exits the function to prevent further processing. If Not IsNumeric(strPartOne) Or Not IsNumeric(strPartTwo) Or Not IsNumeric(strPartThree) Then RectifyDateFormat = Null Exit Function End If ' Declare integer variables for the day, month, and year ' These declarations create integer variables to hold the day, month, and year components of the date. ' These will be used for further processing and validation of the date before returning the formatted result. Dim intDay As Integer, intMonth As Integer, intYear As Integer ' Analyze the parts to determine their roles ' This block of code evaluates the lengths of the date parts to determine their roles as day, month, or year. ' Depending on the format of the input string, it assigns the appropriate values to intYear, intMonth, and intDay. AnalyzeDateParts strPartOne, strPartTwo, strPartThree, intDay, intMonth, intYear ' Validate the final values ' This conditional checks if the final values for day, month, and year are valid. ' If any value is outside the expected range, the function returns Null to indicate an invalid date. If Not IsValidDate(intDay, intMonth, intYear) Then RectifyDateFormat = Null Exit Function End If ' Create the date and format it ' This line creates a date using the DateSerial function, which takes year, month, and day as parameters. ' The resulting date is then formatted as a string in the "dd/mm/yyyy" format. ' The formatted date string is assigned to the function's return value, RectifyDateFormat. RectifyDateFormat = Format(DateSerial(intYear, intMonth, intDay), "dd/mm/yyyy") Exit Function ' This line exits the function normally. ' If no errors occur, the code will not reach the ErrorHandler section. ErrorHandler: ' Handle errors gracefully ' If an error occurs in the preceding code, this line sets the return value of the function to Null, ' indicating that the date format correction failed due to an error. RectifyDateFormat = Null End Function Private Function ReplaceSymbols(inputString As String, SymbolsToRemove As Variant) As String ' This function iterates through an array of symbols that should be replaced with hyphens. ' Each symbol in the SymbolsToRemove array is checked, and if it's not a hyphen, ' it is replaced in the input string with a hyphen. Dim strSymbol As Variant For Each strSymbol In SymbolsToRemove If strSymbol <> "-" Then inputString = Replace(inputString, strSymbol, "-") End If Next strSymbol ReplaceSymbols = inputString End Function Private Function CleanHyphens(inputString As String) As String ' This function replaces double hyphens with a single hyphen and trims the input string. inputString = Trim(Replace(inputString, "--", "-")) ' Remove leading hyphens ' This loop checks if the first character of the input string is a hyphen. ' If it is, the hyphen is removed by taking the substring starting from the second character. Do While Left(inputString, 1) = "-" inputString = Mid(inputString, 2) Loop ' Remove trailing hyphens ' This loop checks if the last character of the input string is a hyphen. ' If it is, the hyphen is removed by taking the substring up to the second-to-last character. Do While Right(inputString, 1) = "-" inputString = Left(inputString, Len(inputString) - 1) Loop CleanHyphens = inputString End Function Private Sub AnalyzeDateParts(strPartOne As String, strPartTwo As String, strPartThree As String, _ ByRef intDay As Integer, ByRef intMonth As Integer, ByRef intYear As Integer) ' This subroutine analyzes the lengths of the date parts to determine their roles as day, month, or year. ' Depending on the format of the input string, it assigns the appropriate values to intYear, intMonth, and intDay. If Len(strPartOne) = 4 Then ' Year is first (Format: YYYY-MM-DD) intYear = CInt(strPartOne) intMonth = CInt(strPartTwo) intDay = CInt(strPartThree) ElseIf Len(strPartThree) = 4 Then ' Year is last (Format: DD-MM-YYYY) intYear = CInt(strPartThree) intMonth = CInt(strPartTwo) intDay = CInt(strPartOne) ElseIf Len(strPartTwo) = 4 Then ' Year is in the middle (Format: DD-YYYY-MM or MM-YYYY-DD) intYear = CInt(strPartTwo) If CInt(strPartOne) > 12 Then intDay = CInt(strPartOne) intMonth = CInt(strPartThree) ElseIf CInt(strPartThree) > 12 Then intDay = CInt(strPartThree) intMonth = CInt(strPartOne) Else intDay = CInt(strPartOne) intMonth = CInt(strPartThree) End If Else ' All parts are small numbers (Format: D-M-YY) intDay = CInt(strPartOne) intMonth = CInt(strPartTwo) intYear = CInt(strPartThree) ' Confirm year is in the correct range ' If the year is provided as a two-digit number, it will be treated as a year in the 2000s. If intYear < 100 Then intYear = intYear + 2000 End If End If End Sub Private Function IsValidDate(intDay As Integer, intMonth As Integer, intYear As Integer) As Boolean ' This function checks if the provided day, month, and year are valid. ' It verifies that the month is between 1 and 12 and that the day is appropriate ' for the given month and year (not exceeding 31 for any month). IsValidDate = (intMonth >= 1 And intMonth <= 12) And _ (intDay >= 1 And intDay <= 31) And _ (intYear >= 1900 And intYear <= 2100) End Function وللتجربة لكل الحالات تقريبا من داخل المحرر '************************************************************************************************************************************* ' Sub: TestRectifyDateFormat ' Purpose: This subroutine tests the RectifyDateFormat function with various input date strings ' to ensure that the function handles different formats and returns the expected results. ' ' Usage: Call TestRectifyDateFormat to run the tests and print the results to the debug output. ' '********************************************************************** ' Author: officena.net™ , Mohammed Essam © , soul-angel@msn.com ® ' Date: October 2024 '********************************************************************** Sub TestRectifyDateFormat() Dim testDate As String Dim result As Variant ' Test various date formats testDate = "30/11/2009" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "2012-06-25" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "21/6/2015م" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = """ 9/1/2014""" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "30\11\2009" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "5/1999/26" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "25/1999/6" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "5/1994/ 26" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "5 1995 26" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "6 1996 26" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result End Sub RectifyDate.accdb

أخي @صباح2024 إدا كنت قد إستوعبت طلبك سنقوم بتعديل الكود بطريقة مختلفة لنتمكن من تنفيد المطلوب بشكل دقيق لان دمج الاكواد على Private Sub Worksheet_Change(ByVal Target As Range) والإشتغال عليها مباشرة من شأنه أن يسبب لك عدة مشاكل خاصة انك ترغب بتحديث البيانات عند كل تغيير على اي خلية لنفترض أنك قمت باسـتدعاء اي اسم مثلا من الطبيعي ان البيانات السابقة مختلفة بمجرد استدعائها سيتم نسخها للاعمدة الخاصة بالاسم الدي تم اختياره مما سيسبب لك تلف وتعارض في البيانات اسف على الإطالة لاكن لابد من توضيح الفكرة ( اليك ما تم الإشتغال عليه) 1) جلب البيانات من ورقة السجل الى ورقة استدعاء بشرط الإسم 2) تحديث البيانات عند التغيير في أي خلية من الخلايا التي تم تمييزها باللون الأصفر على ورقة استدعاء على الأعمدة المناسبة في ورقة السجل مع مراعات الإسم 3) تم اظافة كود لإنشاء قائمة منسدلة ديناميكية بالأسماء الفريدة من العمود B ( ورقة السجل) بداية من الصف 2 تلقائيا في خلية الإسم (B6) ورقة استدعاء الأكواد المستخدمة : Public Property Get WS() As Worksheet Set WS = Sheets("استدعاء") End Property Public Property Get dest() As Worksheet Set dest = Sheets("السجل") End Property ' خلية الإسم Public Function Clé() As String Clé = WS.Range("B6").Value End Function 'نطاق البحث Public Function rng() As Range Set rng = dest.Range("B2:B" & dest.Cells(dest.Rows.Count, 2).End(xlUp).Row) End Function '======================== ' جلب البيانات من ورقة السجل إلى ورقة "استدعاء" Sub Fetch_data() Dim data As Variant, i As Long, tmp As Range Application.ScreenUpdating = False On Error GoTo CleanExit Set tmp = rng.Find(Clé, LookIn:=xlValues, LookAt:=xlWhole) If tmp Is Nothing Then MsgBox "لم يتم العثور على الإسم" & " : " & Clé & " في السجل", vbExclamation Exit Sub End If For i = 0 To 3 data = dest.Range(tmp.Offset(0, 1 + (i * 9)), tmp.Offset(0, 9 + (i * 9))).Value WS.Range("A" & (9 + (i * 3)) & ":I" & (9 + (i * 3))).Value = data Next i CleanExit: Application.ScreenUpdating = True End Sub '======================== ' تحديث البيانات من ورقة استدعاء الى ورقة السجل Sub Update_data() Dim tmp As Range, cnt() As Variant, OnRng As Range Dim ColArr() As Long, j As Long, i As Long Set OnRng = rng.Find(Clé, LookIn:=xlValues, LookAt:=xlWhole) If OnRng Is Nothing Then MsgBox "لم يتم العثور على الإسم" & " : " & Clé & " في السجل", vbExclamation Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim Irow As Long Irow = OnRng.Row ReDim ColArr(0 To 35) For j = 0 To 35 ColArr(j) = j + 3 Next j ReDim cnt(UBound(ColArr)) For i = 0 To UBound(cnt) cnt(i) = WS.Cells(9 + (i \ 9) * 3, 1 + (i Mod 9)).Value Next i For i = 0 To UBound(ColArr) If dest.Cells(Irow, ColArr(i)).Value <> cnt(i) Then dest.Cells(Irow, ColArr(i)).Value = cnt(i) End If Next i Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub '======================== ' إضافة قائمة منسدلة بالأسماء المتوفرة في ورقة "السجل" Sub Add_listeDéroulante() Dim lr As Long, arr() As String, r As Range, i As Long Dim cnt As New Collection, Names As Range lr = dest.Cells(dest.Rows.Count, 2).End(xlUp).Row On Error Resume Next For Each r In rng If r.Value <> "" Then cnt.Add r.Value, CStr(r.Value) End If Next r On Error GoTo 0 If cnt.Count = 0 Then Exit Sub ReDim arr(1 To cnt.Count) For i = 1 To cnt.Count arr(i) = cnt(i) Next i Set Names = WS.Range("B6") With Names.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=Join(arr, ",") .IgnoreBlank = True: .InCellDropdown = True: .ShowInput = True: .ShowError = True End With End Sub وفي حدث ورقة استدعاء Private Sub Worksheet_Activate() Add_listeDéroulante End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim Clé As Range, cntArr As Range Set Clé = WS.Range("B6") If Clé.Value = "" Then Exit Sub If Target.Address = Clé.Address Then On Error GoTo ErrorHandler Fetch_data Exit Sub End If ' عناوين الخلايا المستهدفة Set cntArr = Me.Range("A9:I9, A12:I12, A15:I15, A18:I18") If Not Intersect(Target, cntArr) Is Nothing Then On Error GoTo ErrorHandler Update_data Exit Sub End If Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description On Error GoTo 0 End Sub وأي إستفسار سنكون دائما سعداء بمساعدتك تحويل التغييرات من شيت الاستدعاء الى شيت السجل.xlsm

السلام عليكم مشاركه مع اخوتى واساتذتى جزاهم الله عنا خيرا بطريقه اخرى عن طريقه اخى واستاذى وشيخنا الجليل @ابوخليل test 110.accdb

السلام عليكم ورحمة الله تعالى وبركاته طبعا قد يقول البعض ان الموضوع اتهرس فى ميت فيلم عربى قبل كده لكن على كل حال تم تدارك الكثير من المشاكل ومعالجتها بشكل احترافى - اخفاء اطار لاكسس بالشكل الطبيعى والتقليدى لعرض النموذج كاملا - اخفاء اطار الاكسس وعمل شفافية للنموذج لاظهار صور png او حسب خيال المسخدم - تم ضبط كواد التوسيط للنماذج والتقارير باحترافية ويعمل التوسيط مع الخاصية Pop Up فى اى وضع كانت فى حالة عدم استخدام الاخفاء - تم حل مشكلة عدم ظهور التقاربر عند الاخفاء بتكبير التقرير تلقائيا عند استخدام كود الاخفاء - امكانبة التصغير للتطبيق بجوار الساعة ( System Try ) - عند التصغير بجوار الساعة ممكن الضغط كليك يمين على الايقونة لتظهر قائمة اختيارات - تم ضبط كود تغير ايقونة الاكسس باحترافية وبشكل تلقائى من المسار المحدد او فى حالة عدم وجود الايقونة ترجع ايقونة الاكسس - تم التعامل مع الاكواد بحرفية تامة للعمل على بيئات الأنوية المختلفة سواء كانت 32 , 64 اترككم مع تجربة شيقة ملاحظة هامة : ارضاء للجميع ولاضفاء اكبر قدر ممكن من المرونة المرفق يحتوى على قاعدتان الاولى : تم تجميع كل الاكواد والدوال فى وحدة نمطية عامة واحدة وكلاس موديول واحد لسهولة الاستفادة منها ونقلهم الى اى قاعدة الثانية : فصل اكواد كل وظيفة على حدة فى مديول خاص بها تم اضافة تعديل وتحديث جديد بتاريخ 11/10/2024 رقم اصدار التعديل الاخيــر : 4.8 center and Hid and Tray Minimizer V 30.zip center and Hid and Tray Minimizer V 4.8.rar

وعليكم السلام في احد مشاريعي ، جابوا لي قائمة اكسل فيها تواريخ مكتوبة بكل ما لذ وطاب من الطرق ، مثل: 30/11/2009 ، 2012-06-25 ، 21/6/2015م ، " 9/1/2014" ، 30\11\2009 ، 5/1999/26 ، 25/1999/6 ، 5/1994/ 26 ، وحتى بعضها بالارقام الهندية ، فعملت الدالة التالية ، والتي ترسل لها التاريخ المطلوب تعديله ، والدالة تصلح التاريخ وترجعه. ومنها تقدر تحصل على السنة 🙂 هذه هي الدالة: Function Date_Rectified(D As String) As Date On Error Resume Next Dim x() As String Dim P1 As String, P2 As String, P3 As String D = Trim(D) D = Replace(D, "(", "") D = Replace(D, ")", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, "*", "") D = Replace(D, "م", "") D = Replace(D, ChrW(1632), "0") 'الرقم الهندي صفر D = Replace(D, ChrW(1633), "1") D = Replace(D, ChrW(1634), "2") D = Replace(D, ChrW(1635), "3") D = Replace(D, ChrW(1636), "4") D = Replace(D, ChrW(1637), "5") D = Replace(D, ChrW(1638), "6") D = Replace(D, ChrW(1639), "7") D = Replace(D, ChrW(1640), "8") D = Replace(D, ChrW(1641), "9") D = Replace(D, "!", "-") D = Replace(D, "/", "-") D = Replace(D, "//", "-") D = Replace(D, "\", "-") D = Replace(D, ".", "-") D = Replace(D, "_", "-") D = Replace(D, "|", "-") D = Replace(D, ",", "-") D = Replace(D, Chr(34), "") If Len(D) = 4 Then 'starts with year, but its 4 digits only:1999 'convert to 1-1-1999 OR EMPTY Date_Rectified = DateSerial(D, 1, 1) Exit Function End If If D = "5/1994/ 26" Then Debug.Print D End If x = Split(D, "-") P1 = x(0): P2 = x(1): P3 = x(2) If Len(P1) = 4 And Len(P2) <> 0 Then 'starts with year, and month exist: 1999-1-2 Date_Rectified = DateSerial(P1, P2, P3) ElseIf Len(P3) = 4 And Len(P2) <> 0 Then 'ends with year, and month exist: 2-1-1999 Date_Rectified = DateSerial(P3, P2, P1) ElseIf Len(P2) = 4 And Len(P1) <= 12 Then 'year in the middle, day and month exist: 5/1999/26 Date_Rectified = DateSerial(P2, P1, P3) ElseIf Len(P2) = 4 And Len(P1) > 12 Then 'year in the middle, day and month exist: 25/1999/6 Date_Rectified = DateSerial(P2, P3, P1) Else 'otherwise Date_Rectified = Null End If End Function

تفضل بالتوفيق test8102024.rar

عشان تقدر تطبق المطلوب كان لابد من عمد كود برمجة فيه داله اسمها MaxNumber تعمل المطلوب وبشكل مختصر هذا كود البرمجة: Function MaxNumber(rng As Range) As Double Dim cell As Range Dim matches As Object Dim largest As Double Dim regex As Object Set regex = CreateObject("VBScript.RegExp") regex.Global = True regex.IgnoreCase = True regex.Pattern = "\d+(\.\d+)?" largest = -1 For Each cell In rng If Not IsEmpty(cell.Value) Then Set matches = regex.Execute(cell.Value) If matches.Count > 0 Then Dim match As Variant For Each match In matches If CDbl(match.Value) > largest Then largest = CDbl(match.Value) End If Next match End If End If Next cell MaxNumber = largest End Function بعد كده اختار أي عمود تحتاجه عادي جدا زي ما بتعمل أي معادلة وهذه المعادلة كده بتكون : =MaxNumber(A1:A100) تحياتي 🙂 اكبر قيمه.xlsm

وعليكم السلام ورحمة الله وبركاته بعد اذن الاستاذ حجازى واثراءا للموضوع واظافة وهي عدم السماح للصف الذي به بيانات باظافة صف فارغ الا مرة واحدة الكود Private Sub CommandButton1_Click() Dim i As Long Dim ws As Worksheet Dim lastRow As Long Dim nextRowData As Long Set ws = ActiveSheet Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False lastRow = ws.Cells.Find(What:="*", After:=ws.Cells(1, 1), LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _ SearchFormat:=False).Row For i = lastRow To 2 Step -1 If Application.WorksheetFunction.CountA(ws.Rows(i)) > 0 Then nextRowData = Application.WorksheetFunction.CountA(ws.Rows(i + 1)) If nextRowData > 0 Then ws.Rows(i + 1).Insert Shift:=xlDown End If End If Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub الملف إضافة صف فارغ.xlsm

و عليكم السلام و رحمة الله و بركاته تفضل أخي الكريم Sub InsertBlankRowForAllColumns() Dim lastRow As Long Dim lastColumn As Long Dim i As Long, j As Long ' تحديد آخر صف وآخر عمود يحتويان على بيانات lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lastColumn = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column ' البدء من آخر صف والعمل إلى الأعلى For i = lastRow To 2 Step -1 ' التحقق من وجود بيانات في أي من الأعمدة For j = 1 To lastColumn If Cells(i, j).Value <> "" Then Rows(i + 1).Insert Shift:=xlDown Exit For ' الخروج من الحلقة الداخلية إذا وجدنا بيانات End If Next j Next i End Sub إضافة صف.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا = "السيد/ مدير إدارة بمحافظة " & INDEX(C5:C100, MATCH(1, SUBTOTAL(103, OFFSET(C5:C100, ROW(C5:C100)-MIN(ROW(C5:C100)), 0, 1)), 0)) = "السيد/ مدير إدارة بمحافظة " & IFERROR(INDEX(C5:C100, MATCH(1, SUBTOTAL(103, OFFSET(C5:C100, ROW(C5:C100)-MIN(ROW(C5:C100)), 0, 1)), 0)), "لا توجد محافظة") او ="السيد/ مدير إدارة بمحافظة " & INDEX(C5:C100, MATCH(1, SUBTOTAL(103, OFFSET(C5, ROW(C5:C100)-ROW(C5), 0, 1)), 0)) طلب.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك استخدام احدى الصيغ التالية للحصول على عدد الذكور مع مراعاة الفلترة لان countif بمفردها لن تأخذ الفلاتر في الاعتبار =SUMPRODUCT(SUBTOTAL(103, OFFSET(K52:K750, ROW(K52:K750) - ROW(K52), 0, 1)), --(K52:K750="ذكر")) او =SUMPRODUCT((K52:K750="ذكر")*(SUBTOTAL(103,OFFSET(K52:K750,ROW(K52:K750)-ROW(K52),0,1)))) =SUMPRODUCT(SUBTOTAL(103, OFFSET(K52:K750, ROW(K52:K750) - ROW(K52), 0, 1)), --(K52:K750="أنثى")) او =SUMPRODUCT((K52:K750="أنثى")*(SUBTOTAL(103,OFFSET(K52:K750,ROW(K52:K750)-ROW(K52),0,1)))) القاعدة 2025 - Copy.xlsx

وعليكم السلام جرب هذا الحل قوائم التلاميذ معدل.xlsm

ومشاركة مع الأستاذ محمد لطفي ، قمت بإنشاء دالة واحدة يتم استدعائها في اي من الزرين لتنفيذ المهمة حسب الزر . Private Sub أمر17_Click() ExportReport "PDF", Me.Namea.Value End Sub Private Sub أمر18_Click() ExportReport "RTF", Me.Namea.Value End Sub Private Sub ExportReport(formatType As String, userName As String) On Error Resume Next Dim fileName As String fileName = userName & " - " & Format(Now(), "yyyy-mm-dd") & " " & Format(Now(), "hh nn AM/PM") & IIf(formatType = "PDF", ".pdf", ".doc") Dim filePath As String filePath = CurrentProject.Path & "\" & fileName DoCmd.OutputTo acOutputReport, namerpts, IIf(formatType = "PDF", acFormatPDF, acFormatRTF), filePath, True, , , acExportQualityPrint End Sub ملفك بعد التعديل ( شريط طباعة.accdb )

العفو أخي يسعدنا أننا إستطعنا مساعدتك إليك طريقة أسرع ومختصرة Option Explicit Sub test2() Dim lastrow&, a&, i&, n&, cnt& Dim f As Worksheet, WS As Worksheet, OnRng As Variant Set WS = Sheets("الخزينه") Set f = Sheets("تحصيلات نقدية") lastrow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row a = f.Cells(f.Rows.Count, "A").End(xlUp).Row + 1 OnRng = WS.Range("B4:G" & lastrow).Value For i = 1 To UBound(OnRng, 1) cnt = Application.WorksheetFunction.CountIfs(f.Range("A2:A" & a - 1), OnRng(i, 1), _ f.Range("B2:B" & a - 1), OnRng(i, 6), _ f.Range("C2:C" & a - 1), OnRng(i, 2), _ f.Range("D2:D" & a - 1), OnRng(i, 5)) If cnt = 0 And (OnRng(i, 6) = "دفعه" Or OnRng(i, 6) = "تصفيه") Then f.Cells(a, 1).Resize(1, 4).Value = Array(OnRng(i, 1), OnRng(i, 6), OnRng(i, 2), OnRng(i, 5)) a = a + 1 n = n + 1 End If Next i MsgBox IIf(n > 0, "تم ترحيل البيانات بنجاح", "البيانات محدثة مسبقا") End Sub مشروع خزنه 1.xlsb

اخي العزيز الغالي ابو بسملة .. جميلة جدا هذه الاستعارة .. في ردي السابق نسيت ان اربط النموذج بالبيانات .. تجدون ادناه تعديل لمرفقي السابق test12.rar

اخوي احمد .. الله يكون بعونك .. ستتعب كثيرا test11.rar

وعليكم السلام ورحمة الله تعالى وبركاته جرب هذا مع تغيير أسماء الأعمدة بما يناسبك =SUMPRODUCT(--(B2:B12<>"")*(B2:B12<>"غ")*(B2:B12<>"غياب")*(B2:B12<>"تخلف")) المصنف1.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا هل يشتغل معك عند محاولة الدخول لورقة 1 TEST.xlsb

وعليكم السلام ورحمة الله وبركاته ,, اخي الكريم انت استخدمت الدالة DLookup لجلب رقم المقترض ( على ما أعتقد ) بناءً على اسم الموظف في الكومبوبوكس ، هل هذا صحيح ؟؟ وبإمكانك بدلاً من ذلك استخدام نفس مصدر الكومبوبوكس com1 ولكن هنا سنختار العمود رقم 2 حيث :- ( العمود 0 = اسم الموظف ، والعمود 1 = الجهة ، والعمود 2 = رقم المقترض ) ، لذا تم استبدال الجملة التالية :- Me.n2 = DLookup("[num]", "karz", "nam LIKE '*" & Me.com1 & "*'") بالجملة :- Me.n2 = com1.Column(2) أيضاً تم إجراء تعديل بسيط على عدد الأعمدة في الكومبوبوكس com1 وعرض كل عمود ؛ كما في الصورة :- الملف بعد التعديل القرضة الحسنة اصدار 31.zip

ناسف ع التاخير غير المقصود ضغط العمل نسال الله دوام التوفيق و السداد للجميع العمل سيكون مقسم الي جزئين الجزاء الاول :- تصدير فاتوره المبيعات , مردوداتها الي ملف xml الحاله :- قريبا جدا بيكون جاهز الجزاء الثاني :- و هو الاهم و الاصعب ربط الحل التقني مع هيئه الزكاه و الدخل الحاله :- جاهز تنويه :- ممكن اي احد شغال ع vb.net او c# او اي لغه برجمه ياخد طريقه العمل ويطبقها بلغه البرمجه الخاصه بيه و هيشتغل معاه ان شاء الله رابط الملفات المستخدمه للعمل ملف الاكسس + البرامج المساعده https://drive.google.com/file/d/1vrIMbKFfU6_HgWipo3L8CLAOGwjvdTvj/view?usp=drive_link رابط ملف الاكسس فقط https://drive.google.com/file/d/1YY5an9X-NYjAx2ZSL6ipr_dQcihcLrCD/view?usp=drive_link رابط الشروحات (الموضوع طويل وفيه تفاصيل كثيره وحاولت ان اختصر قدر المستطاع ) للتواصل :- ايميل :- act32add.nm@gmail.com واتساب :- 00966597465617

حدد الخلية التي تحتوي على المعادلة (E3) توجه إلى علامة التبويب (Home) في شريط الأدوات في جزء التنسيق (Number Format) تحقق من نوع التنسيق المستخدم ستجده مضبوطا على (Text) قم بتغييره الى (General) عدم ظهور نتيجة المعادلة_٠٨٢٤١٠.xlsx تبسيط المعادلة =IF(AND(J3<>"", I3<>""), WORKDAY.INTL(I3, J3, 15), "")

وعليكم السلام ورحمة الله تعالى وبركاته ادا كنت تقصد انك ترغب بجمع القيمة الإجمالية في العمود "K" التي تتوافق مع القيم الفريدة في العمود "C" إليك اقتراح اخر بطريقة مختصرة Sub test1() Dim SumCel As Range Dim f As Worksheet, Irow As Long, r As Long Dim dict As Object, n As Double, tmp As String Set f = ThisWorkbook.Sheets("Sheet1") Irow = f.Cells(f.Rows.Count, "C").End(xlUp).Row Set SumCel = f.[O5] Set dict = CreateObject("Scripting.Dictionary") For r = Irow To 4 Step -1 tmp = f.Cells(r, "C").Value If Not dict.exists(tmp) Then dict.Add tmp, f.Cells(r, "K").Value End If Next r n = Application.Sum(dict.Items): SumCel.Value = n End Sub تجارب اجمالى العهدة V1.xlsb

بالإضافة لطريقة المهندس @محمد احمد لطفى جرب هذه الطريقة أيضا 🙂 : If IsDate(Me.datex) Then Me.datex2 = Year(CDate(Me.datex)) End If test8102024.rar

تحياتي للأستاذ / أمير حل رائع . إضافة بسيطة و هو كود لاستحراج أكبر قيمة مع النص الموجود بجانب الرقم Function LargestValueWithOriginalText(rng As Range) As String Dim cell As Range Dim matches As Object Dim maxNum As Double Dim num As Double Dim regex As Object Dim resultText As String ' Create a regular expression object Set regex = CreateObject("VBScript.RegExp") regex.Pattern = "\d+\.?\d*" ' Pattern to match numbers (including decimals) regex.Global = True maxNum = -1 ' Initialize maxNum to a low value resultText = "No numeric values found." ' Default message ' Loop through each cell in the specified range For Each cell In rng If Not IsEmpty(cell.Value) Then ' Find all matches in the cell Set matches = regex.Execute(cell.Value) ' Loop through all found matches For Each Match In matches num = CDbl(Match.Value) ' Convert match to a number If num > maxNum Then maxNum = num ' Update maxNum if the current number is larger resultText = cell.Value ' Store the text of the cell with the largest number End If Next Match End If Next cell ' If a number was found, return the original text If maxNum > -1 Then LargestValueWithOriginalText = resultText Else LargestValueWithOriginalText = resultText End If End Function اكبر قيمه (2).xlsm

يمكنك عمل ذلك من خلال التنسيق الشرطي عن طريق معادلة =OR(C$6="الجمعة",C$6="السبت") وتطبق على الخلايا C7:AH56 بالتوفيق

وعليكم السلام ورحمة الله وبركاته نعم، يمكنك ربط ملف Excel بملف Access عند عمل تحديث بيانات أو اضافة في ملف اكسل تنتقل هذه االتحديثات أو الاضافات أو التغييرات الى ملف اكسس اتبع الخطوات في الصور قاعدة بيانات.zip اكسل.xlsm

اتمني اكون سددت المطلوب Sub DeleteRows() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("ورقة1") Dim response As VbMsgBoxResult response = MsgBox("هل أنت متأكد أنك تريد نقل البيانات وحذفها من الجدول الأساسي؟", vbYesNo + vbQuestion, "تنبيه") If response = vbNo Then Exit Sub End If Dim lastRow As Long Dim lastRow1 As Long lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row lastRow1 = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row ws.Range("F3:J" & lastRow1).Clear ws.Range("A2:D" & lastRow).Copy ws.Range("G2").PasteSpecial Paste:=xlPasteAll ws.Range("A3:D" & lastRow).Clear ws.Range("F1:J1").Merge ws.Range("F1").Value = ws.Cells(1, 1).Value ws.Range("F1").NumberFormat = "dddd dd - mm - yyyy" With ws.Range("F1") .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Font.Size = 18 .Font.Bold = True .Interior.Color = RGB(217, 217, 217) End With With ws.Range("F2:J2") .Interior.Color = RGB(217, 217, 217) .Font.Size = 16 .Font.Bold = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With With ws.Range("G3:J" & lastRow) .Font.Size = 16 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With ws.Cells(2, "F").Value = "ت" Dim i As Long For i = 3 To lastRow ws.Cells(i, "F").Value = i - 2 Next i ws.Range("F2:F" & lastRow).Borders.LineStyle = xlContinuous ws.Range("F2:F" & lastRow).HorizontalAlignment = xlCenter ws.Range("F2:F" & lastRow).VerticalAlignment = xlCenter ws.Columns("F").ColumnWidth = 6 ws.Columns("G").ColumnWidth = 16.88 ws.Columns("H").ColumnWidth = 19.68 ws.Columns("I").ColumnWidth = 19.38 ws.Columns("J").ColumnWidth = 8.5 Application.CutCopyMode = False ws.Cells(1, 1).Value = ws.Cells(1, 1).Value + 1 End Sub عمل تنسيقات بعد الضغط على الزر.xlsm

يمكنك استعمال هذه المعادلة في الخلية D6 =IFERROR(INDEX(الاسماء!$G$6:$G$215,MATCH(الخطة!D6,الاسماء!$F$6:$F$215,0)),"") ثم سحب المعادلة للأسفل ويسارا وإذا كنت تستعمل النسخ الحديثة للأوفيس يمكنك استعمال هذه المعادلة بدون سحب في الخلية D6 فقط' =IFERROR(INDEX(الاسماء!$G$6:$G$215,MATCH(الخطة!D6:AD230,الاسماء!$F$6:$F$215,0)),"") بالتوفيق

فيديو الشرح احببت مشاركتكم لهذا الفيديو المشار اعلاه والتي تقوم فكرته على وللذين لديهم معرفة ولو بسيطة عن البايثون فلو اردت مشاركة بياناتك الحالية مثل كشف حساب او ادخالاتك مع احد الاشخاص على الانترنت استخدام streamlit او flask او flet لانشاء نماذج المستخدم استخدلم sqlalchemy لاستخام عبارات ال sql استخدام ngrok لنشر الداتا على الانترنت مع مراعاة استخدام بايثون 64 او 32 بت حسب الاوفيس ان كان32 او 64 وايضا engine office العملية سهلة التطبيق وكذلك الاكواد مرفقة بالفيديو

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

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

بالنسبة للحفظ والحذف اكسس يحفظ آليا بدون أمر .. بمجرد الكتابة اما الحذف فأرى ان يتم الحذف من نموذج التعديل ,, لأن البيانات ستكون ظاهرة فيه الرئيسي اعمل له زر ماكرو .... والفرعي جاهز فقط يتم التحديد على السجل ثم زر delet ---------------------------------- اعجبني مثالك .. اذا وجدت الوقت الكافي سوف اعمل تحسينات جوهرية عليه ----------------------------------------------- تفضل هذه طريقة الترقيم الخاص Dim xLast, xNext As Integer Dim prtyr, prtTxt As Integer xLast = DMax("moveCode", "tblInvoiceHeader", "Left(moveCode, 1) ='" & "W" & "'") prtyr = Left(xLast, 1) If IsNull(xLast) Then xNext = 1 prtyr = "W" Else xNext = Val(Mid(xLast, 2, 5)) + 1 End If Me!moveCode = prtyr & Format(xNext, "00000") stock10 .rar

حسب فهمى للطلب =IF(G3="";"";INT(DATEDIF(G3;TODAY();"m")/4)*10) TESTT.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub Worksheet_Change(ByVal Target As Range) Dim OnRng As Range, arr As Range, dict As Object, n As Long, f As String Dim lastRow As Long, SumCol As Long, a As Long Dim WS As Worksheet: Set WS = Me lastRow = WS.Columns("C:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If Not Intersect(Target, WS.Range("C6:D" & lastRow)) Is Nothing Then With Application .DisplayAlerts = False .ScreenUpdating = False If lastRow > 6 Then With WS.Range("E6:E" & lastRow) .UnMerge .ClearContents End With End If Set dict = CreateObject("Scripting.Dictionary") SumCol = WS.Cells(WS.Rows.Count, 3).End(xlUp).Row Set OnRng = WS.Range("C6:C" & SumCol) Set arr = WS.Range("D6:D" & SumCol) For n = 1 To OnRng.Rows.Count f = Trim(OnRng(n).Value) If Len(f) > 0 And IsNumeric(arr(n).Value) Then If dict.Exists(f) Then dict(f) = dict(f) + arr(n).Value Else dict.Add f, arr(n).Value End If End If If Len(Trim(arr(n).Value)) = 0 Then WS.Cells(n + 5, 5).Value = "" End If Next n n = 6 Do While n <= SumCol f = Trim(WS.Cells(n, 3).Value) If Len(f) > 0 Then If dict.Exists(f) Then WS.Cells(n, 5).Value = dict(f) a = n Do While n <= SumCol And Trim(WS.Cells(n, 3).Value) = f n = n + 1 Loop If n - a > 1 Then WS.Range(WS.Cells(a, 5), WS.Cells(n - 1, 5)).Merge End If Else n = n + 1 End If Else n = n + 1 End If Loop Set dict = Nothing .ScreenUpdating = True .DisplayAlerts = True End With End If End Sub جمع ودمج بشرط التاريخ.xlsm

تعديل للملف اظهار نتائج البحث في اللستبوكس.xlsm

هذا يعتمد على طريقة بنائك لعناصر القائمة ليست بوكس أثناء إضافة العناصر إليها يمكنك التحكم في تنسيق القيم الموجودة في الخلايا مثلا بهذه الصورة Dim i As Integer For i = 1 To 10 ListBox1.AddItem Format(Cells(i, 1).Value, "0.00") Next i هذا الكود يقوم بإضافة الخلايا من A1:A10 إلى القائمة وتنسيق الرقم بها إلى رقمين عشريين بالتوفيق

وعليكم السلام ورحمه الله وبركاته تفضل مقارنة.xlsb

اعتذر على التأخير اتفضل يا سيدى تم تحويل القاعدة للتنسيق 2000 بامتداد mdb الاكواد تعمل على النواتان 32 , 64 بيت Security(Enable-Disable Shift Key).zip

وعليكم السلام ورحمه الله وبركاته تفضل رسالة واتساب عام محدث7.xlsm

مرفق ملف للترجمه بواسطه السيلينيوم * لابد من تصطيب السيلينيوم ويمكنك تحميله من هذا الرابط * وتحديث درايفر الكروم من هذا الرابط Translator.xlsm