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

ما شاء الله بارك الله أحسنتم بارك الله بكم

Try this formula =MID(LEFT(A1,LEN(A1)-6),5,LEN(LEFT(A1,LEN(A1)-6)))

أخي @Abdelaziz Osman ، لا تحتاج كود لهذه الوظيفة فآكسيس يوفرها لك من خلال أن تحدد مربع النص الذي تريده ، ثم من تبويب Format ، انزل لآخر خيار Try.accdb

عليكم السلام ورحمة الله وبركاته يمكنك استعمال هذه المعادلة المختصرة على اعتبار أن الرقم موجود في الخلية A2 =MID(A2,5,LEN(A2)-10) بالتوفيق

لسيادتكم جزيل الشكر @kkhalifa1960 بالفعل محاولة بالغة المهارة

استاذ @Abdelaziz Osman إذا تبغي عند حذف سجل الحفاظ على المعلومات اتبع محاولتي الأولي . أما إذا تبغي عند حذف سجل الحفاظ على الترقيم متسلسل أنظر نموذج 2 . بعد حذف السجل رقم 3 كما بالمرفق . عدم تجاوز التسلسل-2.rar

مشاركة مع استاذ @Foksh تفضل استاذ @Abdelaziz Osman محاولتي ...... وليش ماتستغل حقل الترقيم التلقائي كما بالشرح والمرفق . عدم تجاوز التسلسل-1.rar

تفضل جرب المرفق __المرتجع - نسخة1.xlsm

عزرا لقد حاولت ومازلت احاول يبدوا ان الباسوورد معقد للغاية الذى ادرجتة فى الملف

هوا ده ياجماعه الحل النهائى... عقاعده بيانات للتجارب الحل النهائى.rarلشان مش لبفتح فوق مش عارف ليه

هذا القسم مخصص للإكسل وبإمكانك أخي طرح هذا السؤال في قسم الأكسس

ستقوم هذه الطريقة بإرشادك لكيفية التخلص من تقييد كلمة المرور الخاصة بملف Excel بما فيها إصدارات مثل Excel 2007 أو 2019. إذا كان يطلب منك إدخال كلمة المرور عند محاولة فتح الملف فيتعين عليك تجربة وهذه هي كيفية إزالة الحماية من على ملف Excel باستخدام ZIP: الخطوة 1: قم بتنزيل وتثبيت أداة 7-Zip، تعتبر ملفات Excel ارشيفات مضغوطة، لذا يمكنك تعديل أجزاء من هذا الأرشيف باستخدام 7-Zip. أيضاً يمكنك استخدام WinRAR أو أي أداة أخرى تدعم الضغط باستخدام ZIP. الخطوة 2: قم بإعادة تسمية امتداد الملف من ".xlsx" إلى ".zip" ثم قم بتطبيق التعديل وقم بالنقر على "نعم" إذا ظهرت لك رسالة تحذير. الخطوة 3: بمجرد فتح ملف الـ Excel باستخدام أداة 7-Zip عن طريق النقر بزر الفأرة الأيمن ثم اختيار فتح الملف باستخدام 7-Zip حيث سيظهر لك العديد من الملفات و المجلدات. الإختيار 1: إزالة حماية ملف الـ Excel باستخدام 7-ZIP الخطوة 1: الآن أصبح لديك إمكانية الوصول إلى مجلد يسمى بـ "xl"، ثم بالنقر على ملفك المشفر (لنفترض أن اسمه "workbook.xml"). الخطوة 2: ابحث عن التعليق الذي يبدأ بـ <workbookProtection.../> ثم قم بإزالته تمام ثم قم بإغلاق المحرر: الأختيار 2: إلغاء حماية ورقة Excel باستخدام 7-ZIP الخطوة 1: إذا كانت الورقة محمية بكلمة مرور اذهب إلى المسار "xl\worksheets\sheet1.xml" (بافتراض أن الورقة المشفرة اسمها sheet1) الخطوة 2: اختر "تعديل" حيث سيفتح لك ملف نصي في أي برنامج تحرير نصوص متاح. الخطوة 3: قم بإزالة التعليق الذي يبدأ بـ <sheetProtection … > لإزالة كلمة المرور من على ورقة الـ Excel. أخيراً، لا تنس تغيير الإمتداد إلى .xlsx مرة أخرى. قم الآن بفتح الملف بشكل طبيعي وستجد أن كلمة المرور قد تمت إزالتها.

ما شاء الله، اتمنى لك التوفيق دائما

تم الإنتهاء من الفكرة ولله الحمد ,, وأرجو التكرم بتجربة الفكرة وإخباري بالنتيجة أو رأيكم .. الكود الأول للزر المسؤول عن طلب إدخال القيمة Private Sub Btn_Job_Click() Dim userInput As String Dim numericValue As Double Do userInput = InputBox("الرجاء إدخال القيمة رقمية", "إدخال قيمة") If userInput = "" Then Exit Sub Else DisplayQiblaDirection userInput End If If IsNumeric(userInput) Then numericValue = CDbl(userInput) Exit Do Else MsgBox "الرجاء إدخال قيمة رقمية فقط", vbExclamation, "قيمة غير رقمية" End If Loop End Sub الدالة التي من خلالها تم حل المشكلة وهي عرض الصورة التي تدل على الزاوية أو القيمة التي تم إدخالها في الرسالة . مع العلم أن كل صورة تمثل 6 درجات Private Sub DisplayQiblaDirection(ByVal userInput As String) Dim secValue As Integer Dim Rx As Integer Dim ctrl As Control Dim numericValue As Double If IsNumeric(userInput) Then numericValue = CDbl(userInput) Else Exit Sub End If Rx = Abs(numericValue) secValue = Abs(Round(numericValue / 6, 0)) If numericValue < 0 Then secValue = (360 - Rx) \ 6 End If For Each ctrl In Controls If Left(ctrl.Name, 1) = "s" Then If Right(ctrl.Name, Len(ctrl.Name) - 1) = secValue Then Me(ctrl.Name).Visible = True Else Me(ctrl.Name).Visible = False End If End If Next End Sub Test Directions.zip

Sub ImportWordTablesArray() Dim tables() As Variant Dim WordApp As Object, WordDoc As Object Dim arrFile As Variant, Filename As Variant Dim Table As Integer, iCol As Integer Dim iRow As Long, Cpt As Long, Counter As Long Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("word") Dim ar(1 To 7) Dim c As Integer Dim cnt As Integer cnt = LBound(ar()) ' قم بتعديل عرض الاعمدة بما يناسبك ar(1) = 10: ar(4) = 28: ar(7) = 85: ar(5) = 28: ar(6) = 35: ar(2) = 14: ar(3) = 68 On Error Resume Next arrFile = Application.GetOpenFilename("ملف وورد (*.doc; *.docx),*.doc;*.docx", 2, _ "اظافة الملف", , True) If Not IsArray(arrFile) Then Exit Sub Application.ScreenUpdating = False Set WordApp = CreateObject("Word.Application") WordApp.Visible = False WS.Cells.Clear For Each Filename In arrFile Set WordDoc = WordApp.Documents.Open(Filename, ReadOnly:=True) With WordDoc Table = WordDoc.tables.Count If Table = 0 Then MsgBox WordDoc.Name & "لا يحتوي على جداول", vbExclamation, "استيراد" End If tables = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, _ 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20) '<- '<- ارقام الصفحات For Counter = LBound(tables) To UBound(tables) With .tables(tables(Counter)) For iRow = 0 To .Rows.Count For iCol = 0 To .Columns.Count Cells(Cpt, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text) Next iCol Cpt = Cpt + 1 Next iRow End With Cpt = Cpt + 1 Next Counter .Close False End With Next Filename WordApp.Quit Set WordDoc = Nothing Set WordApp = Nothing lr = WS.Columns("A:G").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1 For Each j In WS.Range("G2:G" & lr) WS.Hyperlinks.Add j, j Next j WS.Rows(1).Interior.ColorIndex = 45 For cnt = LBound(ar()) To UBound(ar()) Columns(cnt).ColumnWidth = ar(cnt) Next cnt Set rngCell = WS.Range("A1 :g" & lr) For Each k In rngCell.Rows If WorksheetFunction.CountA(k) > 0 Then k.Borders.ColorIndex = 5 'c.Borders.LineStyle = xlContinuous Next With WS.Range("a2:a" & WS.Cells(Rows.Count, "b").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-1") End With End Sub https://streamable.com/xdlk5v TEST WORD.rar

للتوضيح فقط لتجاوز حد 10 أعمدة لخاصية AddItem لعنصر التحكم، يتعين عليك استخدام إما خاصية القائمة المضافة من محتويات صفيف (يمكن أن تكون Range.Value) أو خاصية Rowsource المتصلة بنطاق ربما لو كان البحث في عمود محدد مسبقا ستكون الامور اسهل بكثير وفقًا لمتطلباتك.و لشكل الملف لديك يجب أن تفعل المصفوفة ثنائية الأبعاد ما تريد، ولاكن أثناء قيامك بالبحث في أوراق متعددة، ستحتاج إلى تحديد حجم المصفوفة بشكل صحيح عن طريق حساب إجمالي عدد التطابقات عبر جميع الأوراق أولاً قبل تعبئتها. صراحة ليس لي الكثير من الوقت لقضائه في هذا الأمر وتم اختباره فقط على بياناتك المرفقة - وبالتالي فإن محاولاتي لتحديث الكود الخاص بك قد تحتاج إلى بعض التعديل/ إعادة التفكير ولكن جرب ما إذا كان هذا سيفعل ما تريد Private Sub CommandButton1_Click() Dim sh As Worksheet Dim Cpt As String, SearchAddress As String Dim Found As Range, wsRangeArr() As Range Dim CountAllMatches As Long, CountMatch As Long Dim i As Long, r As Long, c As Long Dim Search As Variant, SearchRange As Variant Dim SearchSheetsArr As Variant, CopyArr() As Variant Const ColCount As Long = 12 SearchAddress = "A:J" SearchSheetsArr = Array("عين غزال", "الجبيهة", "أربد", "الزرقاء") '---------------------------------------------------------------------------------------------------------- Search = Me.TextBox1.Value If Len(Search) = 0 Then Exit Sub If IsDate(Search) Then Search = DateValue(Search): LookIn = xlFormulas Else LookIn = xlValues For Each sh In ThisWorkbook.Worksheets(SearchSheetsArr) CountMatch = Application.CountIf(sh.Range(SearchAddress), Search) If CountMatch > 0 Then i = i + 1: ReDim Preserve wsRangeArr(1 To i): Set wsRangeArr(i) = sh.Range(SearchAddress) 'العدد الإجمالي لجميع التطابقات في النطاقات CountAllMatches = CountAllMatches + CountMatch End If CountMatch = 0 Next sh On Error Resume Next If CountAllMatches > 0 Then ReDim CopyArr(1 To CountAllMatches, 1 To ColCount) 'أوراق البحث / النطاقات مع التطابقات r = 0 For Each SearchRange In wsRangeArr 'نطاق البحث Set Found = SearchRange.Find(Search, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False) Cpt = Found.Address Do 'ملء عناصر المصفوفة r = r + 1 For c = 1 To UBound(CopyArr, xlColumns) - 2 CopyArr(r, c) = SearchRange.Cells(Found.Row, c).Text Next c CopyArr(r, c) = Found.Address CopyArr(r, c + 1) = SearchRange.Parent.Name Set Found = SearchRange.FindNext(Found) Loop While Found.Address <> Cpt Set Found = Nothing Next SearchRange End If 'ملء مربع القائمة أو الإبلاغ عن عدم وجود تطابقات With Me.ListBox1 .ColumnCount = IIf(CountAllMatches > 0, ColCount, 1) .List = IIf(CountAllMatches > 0, CopyArr, Array("ما تحاول البحث عنه غير موجود في الاسواق")) .Font.Size = IIf(CountAllMatches > 0, 9, 24) .TextAlign = IIf(CountAllMatches > 0, fmTextAlignLeft, fmTextAlignCenter) End With End Sub Private Sub TextBox1_Change() If Len(Me.TextBox1) = 0 Then Me.ListBox1.Clear End Sub Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Me.TextBox1 = "": Me.ListBox1.Clear End Sub جديد v2.xlsm

السلام عليكم هو امتداد الملف ايه وهل هو قديم ملف جديد وما نوع الاوفيس المستخدم في تصميمه ممكن احاول اساعدك لو الملف قديم

استاذ @زيد يحي اذا كان هذا طلبك لا تنسي انهاء الموضوع بالضغط على أفضل اجابة .

Sub PDF_شيت_ترم_2() Dim FSO As Object Dim S(1) As String Dim sNewFilePath As String Dim Row As Long Set FSO = CreateObject("Scripting.FileSystemObject") S(0) = ThisWorkbook.FullName If FSO.FileExists(S(0)) Then S(1) = FSO.GetExtensionName(S(0)) If S(1) <> "" Then S(1) = "." & S(1) Set WS = ActiveSheet lastRow = WS.Columns("A:A").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row With WS.PageSetup .PrintArea = "$A$3:$CH$" & lastRow End With sNewFilePath = ThisWorkbook.Path & "\شيت الصف السادس ترم ثان.pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sNewFilePath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End If Else MsgBox "لم يتم حفظ الملف ..يوجد خطأ ما " End If Sheets("شيت2").Activate Set FSO = Nothing ' mainy m = MsgBox("تم تصدير الشيت خارج الشيت بإسم شيت الصف السادس ترم ثان" & vbNewLine _ & "هذا الملف موجود فى نفس مكان برنامج الكنترول شيت", _ vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal + vbMsgBoxRight, _ "تم تصدير شيت صف السادس ترم 2 بصيغة pdf.") End Sub

شكر وتقدير واحترام من اخيك حفظكم الله وبارك الله فيك اخي الكريم الحبيب

الكود يعمل في مرفقك أخي الكريم بدون أي مشاكل ، تم اضافة ايقونات للأزرار ، وهذا موقع يعطيك أيقونات بشكل جميل FinancialPrg6 (1).accdb

في الوقت الحالي هذا العداد من 1 إلى 160 .. ولو تم إدخال رقم أقل من الصفر أو أعلى من 160 فسيقف عند الحد الأدنى أو الأعلى .. أما لو كنت تقصد أن الحالة لديك تستدعي ترقيم مختلف ، حينها سنحتاج لإعادة التصميم والأرقام المخزنة 😁 (وهذا سهل إن شاء الله ) .. ولكني سأقف هنا حتى أستمتع بالنظر إلى فكرتك 😄

وهذه مغامرتي وتجربتي بعد العديد من المحاولات 😊 قابلة للتطوير كما تحب 🤗 ‏‏Meter -Moosak _ Final.accdb

جزاك الله خيراً وجعل الله هذا العمل فى ميزان حسناتك

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

تفضل اخى ارسال واتساب.xlsm

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