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

بالعكس استاذي الفاضل ، انت لك بصمتك في المنتدى ، واعذرني أنت لسهوي عن اكمال المهمة التي استفسرت عنها في موضوعك. كل الاحترام والتقدير لك ☺️

Private Sub Worksheet_Change(ByVal Target As Range) Dim Lr As Long Set V1 = Sheet4: Set V2 = Sheet10: Set V3 = Sheet11 Lr = V1.Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row Application.ScreenUpdating = False V2.Range("F9:F" & Lr).Value = V1.Range("F9:F" & Lr).Value V3.Range("F9:F" & Lr).Value = V1.Range("L9:L" & Lr).Value V3.Range("H9:H" & Lr).Value = V1.Range("O9:O" & Lr).Value Application.ScreenUpdating = True End Sub

السلام عليكم ورحمه الله

ليش هاني مجدي والمنتدى مملوء ببرامج المطعم ابحث بالمنتدى (مطعم) بتحصل ماتريد ................. يوجد ملاحظة أخرى أقرأ اسفل مشاركتي ملاحظات مهمه : من استاذنا @Bluemind 1-نتيجة البحث بكلمة مطعم هنا . https://www.officena.net/ib/search/?&q=%D9%85%D8%B7%D8%B9%D9%85&type=downloads_file&quick=1&item=121275&nodes=5&search_and_or=or&sortby=relevancy 2-نتيجة البحث بكلمة Restaurant هنا . https://www.officena.net/ib/search/?&q=restaurant&type=downloads_file&quick=1&item=121275&nodes=5&search_and_or=or&sortby=relevancy

السلام عليكم ورحمة الله جرب الملف المرفق (يجب مراجعة التنسيق الشرطي على العلامات)... برنامج شهادات.xls

عدلت لك شئ مهم ماتحتاج كتابة (ProductionNO) هو بيكتبه لك حسب الجدول المختار من الكمبوبكس . M-2.accdb

حاولي ان يكون المثال عند طرحه على اسمه ( مثال ) يحتوي على بيانات قدر الحاجة تم تأسيس الجداول انظري جيدا في الجداول الثلاث والعلاقات بينها .. والحقول التي تم ادراجها من اجل الربط بينها وانظري في العلاقات المصنوعة بين الجداول هكذا يجب ان تكون تم ازالة حقلي المجموعات والمجموعات الفرعية من جدول التحاليل .. لأن المعرفات المترابطة تقوم بالمهمة lab5.rar يمكنك اضافة التحاليل الى المجموعات الفرعية وسوف تأخد نفس معرف المجموعة الفرعية .. انا اكتفيت بتحليل واحد لكل مجموعة

لربما اخي الكريم سهوت عن تعديل الكود في الزر الآخر .. وقد جربت الزر حفظ الصور أولا لأنه هو من ظهر أمامي فوق زر حفظ الـ Pdf ، فاعذرني 😊 تفضل IMage_PDF.accdb

تمت التجربة و الملف يعمل يجب ان يكون بجوار البرنامج فولدر Myfiles وبداخله فولدر My pdf Bbb.rar

اذا لم تكن بسبب امتداد الحفظ .. : تأكد ان المجلد بجانب قاعدة البيانات .. وتأكد من اسماء المجلدات ( انسخ الاسماء من الكود وغيرها في المجلدات .. يمكن خلل خفي في التسمية ) واما ان تكون بسبب نقص مكتبة .. وهذا مستبعد لان الخطأ لو كان بسبب المكتبة لتم تحديد الدالة فقط وهذا يحدث غالبا

الحل انك تقوم بتعديل اسماء التكست بوكس 35 و 36 انت لما بتعدل بتنسخ قيمة تيكست بوكس البحث حاول تغيير اسمها لاسم اخر واعادة تسمية التيكست بوكس 36 الا 35 بدون ما تنسى تغيير الاسماء داخل الاكواد

تفضل سيتم تنفيد الكود الخاص بكل ورقة عمل عند التغيير في احدى خلايا تاريخ البداية او النهاية سواءا في ورقة 4 او 10 في module جديد انسخ الاكواد التالية Sub test1() '********************************* تقرير الاصناف Dim Sh As Worksheet: Set Sh = Sheet4 Dim Sh1 As Worksheet: Set Sh1 = Sheet6 Dim Sh2 As Worksheet: Set Sh2 = Sheet8 b = Sh1.Name: C = Sh2.Name With Application .ScreenUpdating = False .Calculation = xlManual End With Set V1 = Sh1.Range("$H$9:$H$1000"): Set V4 = Sh2.Range("$H$9:$H$1000") Set V2 = Sh1.Range("$B$9:$B$1000"): Set V5 = Sh2.Range("$B$9:$B$1000") Set V3 = Sh1.Range("$E$9:$E$1000"): Set V6 = Sh1.Range("$E$9:$E$1000") With Range("G9:G" & Range("C" & Rows.Count).End(3).Row) .Formula = "=SUMIFS('" & b & "'!" & V1.Address & ",'" & b & "'!" & V2.Address & ","">=""&$F$7,'" & b & "'!" & V2.Address & ",""<=""&$I$7,'" & b & "'!" & V3.Address & ",C9)" .Value = .Value With Range("H9:H" & Range("C" & Rows.Count).End(3).Row) .Formula = "=SUMIFS('" & C & "'!" & V4.Address & ",'" & C & "'!" & V5.Address & ","">=""&$F$7,'" & C & "'!" & V5.Address & ",""<=""&$I$7,'" & C & "'!" & V6.Address & ",C9)" .Value = .Value End With End With With Application .ScreenUpdating = True .Calculation = xlAutomatic End With End Sub Sub test2() '************************ 'الجرد الشهري Dim MyRng As Range Dim Sh As Worksheet: Set Sh = Sheet10 Dim Sh1 As Worksheet: Set Sh1 = Sheet6 Dim Sh2 As Worksheet: Set Sh2 = Sheet8 b = Sh1.Name: C = Sh2.Name Set MyRng = Sh.Range("A9:M44") With Application .ScreenUpdating = False .Calculation = xlManual End With Set V1 = Sh1.Range("$H$9:$H$1000"): Set V4 = Sh2.Range("$H$9:$H$1000") Set V2 = Sh1.Range("$B$9:$B$1000"): Set V5 = Sh2.Range("$B$9:$B$1000") Set V3 = Sh1.Range("$E$9:$E$1000"): Set V6 = Sh1.Range("$E$9:$E$1000") With Range("H9:H44") .Formula = "=SUMIFS('" & b & "'!" & V1.Address & ",'" & b & "'!" & V2.Address & ","">=""&$E$5,'" & b & "'!" & V2.Address & ",""<=""&$G$5,'" & b & "'!" & V3.Address & ",C9)" .Value = .Value With Range("J9:J44") .Formula = "=SUMIFS('" & C & "'!" & V4.Address & ",'" & C & "'!" & V5.Address & ","">=""&$E$5,'" & C & "'!" & V5.Address & ",""<=""&$G$5,'" & C & "'!" & V6.Address & ",C9)" .Value = .Value End With End With MyRng.Replace 0, "", xlWhole With Application .ScreenUpdating = True .Calculation = xlAutomatic End With End Sub في حدث ورقة 4 Private Sub Worksheet_Change(ByVal Target As Range) Dim Lr As Long Application.ScreenUpdating = False Set V1 = Sheet4: Set V2 = Sheet10: Set V3 = Sheet11 Lr = V1.Range("C" & Rows.Count).End(xlUp).Row V2.Range("F9:F" & Lr).Value = V1.Range("F9:F" & Lr).Value V3.Range("F9:F" & Lr).Value = V1.Range("L9:L" & Lr).Value V3.Range("H9:H" & Lr).Value = V1.Range("O9:O" & Lr).Value If Intersect(Target, Range("F7:i7")) Is Nothing Then Exit Sub On Error Resume Next Application.EnableEvents = False Call test1 Application.EnableEvents = True On Error GoTo 0 Application.ScreenUpdating = True End Sub في حدث ورقة 10 Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Application.ScreenUpdating = False If Intersect(Target, Range("E5:G5")) Is Nothing Then Exit Sub Application.EnableEvents = False Call test2 Application.EnableEvents = True On Error GoTo 0 End Sub

طيب ..هي القاعدة الخلفية ممكن لاي مستخدم ان يدخل لها ؟

ليش ما يصير ؟ بعد اذن اخي استاذ @kkhalifa1960 DD227-2.rar

لاتحتاج الى الرسائل فهي غير عملية حسب رايي عملت لك مربع نص برصيد المادة..حينما تختار اسم المادة سيظهر لك رصيد المادة السابق وحين اختيار الكمية سيظهر لك الرصيد الحالي 444.rar

اولا تأكد من اسم الفولدر في المثال الاسم my files يختلف عن ما كتبته اعلاه myfiles الشيء الآخر ليش تعمل مجلدات تلقائية ؟ اذا اردت بيع برنامجك ارسله مع الفولدرات .. انا اعتبر مثل هذه الخطوات الزام مالا يلزم

المثال يعمل يمكن السبب في تأمين الملف جرب كذا باستخدام الضغط aaa.rar

محاولة في المرفقات... مخطط جلوس.xlsb

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

ملف شهادة مدرسية صالحة للمتوسط أو الثانوي أردت نشرها تعميم للفائدة وهي من إنجازي sadok 2018X2019.xlsm

السلام عليكم ورحمة الله وبركاته كل عام وانتم بخير دالة kh_ShowImage دالة تمكنك من وضع صورة داخل شكل تلقائي اتوماتيكيا يمكنك تغيير اسم او مسار مجلد الصور من داخل كود الدالة وسائط الدالة NameImag اسم الصورة افتراضي ImagRng خلية وضع الصورة افتراضي MyWidth عرض الصورة اختياري MyHeight طول الصورة اختياري ـ اذا لم تحدد طول او عرض معين للصورة تاخذ الصورة عرض وطول الخلية الموضوعة فيها ImagRng ـ اذا قمت بتحريك الصورة يدويا تفقد الصورة ارتباطها بالدالة وعند تحديث الدالة تقوم باضافة الصورة مرة اخرى في مكانها المحدد في الدالة كود الدالة: Option Explicit Option Compare Text '============================================= ' عرض صورة في الخليةِ ' Showing an image in cell '============================================= ' اسم مجلد الصور ' اذا كان مجلد الصور في نفس مجلد ملف الاكسل ' اكتب اسمه فقط ' والا اكتب المسار كاملا ' "D:\MyDocument\MyFunction\photo" Private Const kh_pic As String = "MyImeg" '============================================= ' امكانية تحرير اي نوع من الصور لديك ادناه Private Const MyTyp As String = ".jpg,.bmp,.gif,.png,.tif" '============================================= '============================================= Function kh_ShowImage(ByVal NameImag, ByVal ImagRng As Range, Optional ByVal MyWidth As Single, Optional ByVal MyHeight As Single) Dim Tp Dim shp As Shape Dim ibo As Boolean Dim MyTop As Single, MyLeft As Single Dim MyFile As String, MyPath As String '---------------------------------- On Error GoTo 1 '---------------------------------- MyTop = ImagRng.Top: MyLeft = ImagRng.Left With ImagRng.Worksheet For Each shp In .Shapes If shp.Top = MyTop And shp.Left = MyLeft Then shp.Delete: Exit For End If Next shp End With '----------------------------------- If IsEmpty(NameImag) Then GoTo 1 '----------------------------------- If MyWidth = 0 Then MyWidth = ImagRng.Width If MyHeight = 0 Then MyHeight = ImagRng.Height '----------------------------------- If Not InStr(kh_pic, ":") Then MyPath = ThisWorkbook.path & "\" MyFile = MyPath & kh_pic & "\" & CStr(NameImag) '----------------------------------- For Each Tp In Split(MyTyp, ",") If Not Dir(MyFile & Trim(Tp), vbDirectory) = vbNullString Then With ImagRng.Worksheet.Shapes.AddShape(msoShapeRectangle, MyLeft, MyTop, MyWidth, MyHeight) .Fill.UserPicture MyFile & Trim(Tp) End With ibo = True Exit For End If Next 1 kh_ShowImage = ibo End Function المرفق 2003-2010 دالة عرض صورة في خلية بطول وعرض اختياري.rar

السلام عليكم الاستاد القدير عبد الله باقشير زادك الله من علمه وادامك للمؤمنين مرجعا لكل تائه او مستفسرا في علم الاكسل جزاك الله خيرا وكل عام وانت بالف خير ان شاء الله

الاخوة السادة الكرام بالاضافة لما تفضل به اخونا المهندس صالح قد كانت لي مشاركة بالمنتدى وعنوانها على الرابط http://www.officena.net/ib/index.php?showtopic=28247 وقد ساعدني اخي العزيز المهندس TAREQ M اطال الله في عمره وبارك الله فيك بهذا الخصوص ولقد وجدت مشاركة حديثة لأخونا المبدع والعلامة الكبير ابوتامر بخصوص المدى الديناميكي http://www.officena.net/ib/index.php?showt...859&hl=.com فقد تفيدكم هذه المواضيع تحياتي

السلام عليكم أخي زياد الحمد لله تمت عملية النقل بنجاح شكرا جزيلا تفضل الملف المرفق وبه عمودين في آخر الشيت وهما فقط لضبط موضوع الدائنين والمدينين أرجو أن يكون هذا هو المطلوب __________________2.rar

السلام عليكم معذرة أخي زياد تفضل ' a = Application.DefaultFilePath & "\All.xls" a = ActiveWorkbook.Path & "\All.xls" رجاء إستبدال السطر الأول في الكود Macro3 بالسطر الثاني إذا لم تستطع ذلك فقط إستبدل الملف Accounts_TEST2 بالأمس بهذا المرفق اليوم Accounts_TEST2.rar

بسم الله الرحمن الرحيم إستيراد وتصدير جدول إكسيل من وإلى الأكسيس يرغب بعض الاخوة فى الاحتفاظ ببيانات جدول الإكسيل فى ملف قواعد بيانات الاكسيس لإسباب منها ::: أن يكون عدد صفوف جدول البيانات كبير نسبيا او لإسباب اخرى قد يكون منها أمن البيانات وعلى ذلك يظل ملف الإكسيل صغير دائما وخفيف فيرغب فى تصدير هذا الجدول إلى ملف MDB الخاص بالاكسيس والمطلوب منك فقط بعد نقل الاكود الى ملفك هو تسمية اول خلية فى جدولك بأسم ( FirstCel ) فى الملف خاصتك ويمكن عمل رتين اتوماتيكيا ليعمل الاتى ::: قبل غلق الملف يعمل على تصدير قاعدة البيانات الى الاكسيس ومسح قاعدة البيانات من ملف الاكسيل فيظل ملف الاكسيل صغير الحجم وخفيف وعند فتح الملف يعمل الروتين اتوماتيكيا على استيراد قاعدة البيانات الى ملف الاكسيل لتعمل عليها المرفقات عبارة عن ::: 1 - ملف البرنامج 2 - ملف فيديو يوضح اسلوب العمل نتمتى صالح الدعاء Omar_1.rar

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

اعتذر عن التأخر في الإجابة يا إخواني الأعزاء. الملف الأول "TDWL2" آمل أن يكون إجابة طلب أخينا أبو علي. والمرفق الثاني "TDWL3" هو إجابة أخينا أبو ياسمين. شاكراً لكم مروركم وتفاعلكم مع الموضوع. TDWL2.rar TDWL3.rar

السلام عليكم نعم يوجد مشكلة بالمنتدى و الادارة قائمة على اصلاح الامر اذا كنت تريد الملف ضع ايميلك وسوف ارسله لك ان شاء الله kfb_0012.rar

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

طبعاً البرنامج مكرر، ولكن كما يقولون كل شيخ وله طريقة. بالنسبة لبرنامج محول التواريخ2 فهو يحول من هجري لميلادي والعكس. أما بالنسبة لبرنامج "الأعمار والفترات الزمنية3" فهو للذين في جهازهم برنامج فجول بيسيك6، لأنني استخدمت به أداة أكتف إكس والمرفقة مع البرنامج. أما الأعمار والفترات الزمنية4 فهو لا يحتاج للفجول بيسيك. ومن مميزات البرنامج أنه يعطيك العمر بالهجري والميلادي ويوم الميلاد والبرج وصفاته. ________.rar

شكرا لك اخى nasersaeed اخى أبوعبدالله يسعدنى ذلك وخصوصا انه موضوع هام جدا لمن اراد اجادة التعامل مع الاكسيل Offset استخدام دالة ( Offset ) لتصنع مدى او نطاق ديناميكى هي دالة حيوية لها كثير من الاستخدامات دالة (Offset) من الدوال الهامة جدا التى تتعامل مع مراجع الخلية وهى من الدوال التى تزيد امكانيات الدوال الاخرى التى تقترن بها ودالة (Offset) تعيد قيمة من اي خلية يشار اليها بعدد من الصفوف والاعمدة التى تبتعد عنها . وصيغة الدالة هى : =OFFSET(reference,rows,cols,height,width) - العامل الاول : الخلية المرجع او الخلية الاساس او الام 2 - العامل الثانى : عدد الصفوف 3 - العامل الثالث : عدد الاعمدة 4 - العامل الرابع : الارتفاع محدد بعدد من الصفوف 5- العامل الخامس : العرض محدد بعدد من الاعمدة وقد تم استخدام دالة () فى المثال الذى اشرت اليه اخى لعمل مدى متحرك او ديناميكى ولنعمل معا مثال بسيط : نحن نريد إنشاء مدى لجدوال من البيانات يحتوى على 10 صف و 5 أعمدة الوضع العادى لهذا الاجراء هو ان نقوم بتعليم هذا المدى بدأ من الخلية (A1) الى الخلية (E10) من قائمة (ادراج / اسم / تعريف) ونكتب اسم هذا المدى وليكن ( Rng) سنجد ان الصيغة الموجود اثناء انشاء الجدول فى الصندوق الحوارى (تعريف اسم) والتى تشير الى احداثيات المدى ( Rng) هى : A1:E10 وهى عبارة عن 10 صف و 5 أعمدة وتظل هكذا دائما هذا المدى دائما ثابت كما نعرف سواء احتوى الجدوال على بيانات او لم يحتوى على بيانات هنا تأتى فائدة انشاء المدى الديناميكى الذى تزاد عدد صفوفة او تنكمش تبعا لأحتواء المدى على بيانات وخاصة فى العمود الاول او حسب اى عمود تريدة ليكون هو الحاكم بأمر المدى حسب احتوائة على بيانات . سنقوم معا بإنشاء نفس المدى ولكن بأسم ( MyRange ) وبنفس الابعاد التى اشرنا اليها وهى عبارة عن 10 صف و 5 أعمدة . ولكن هذه المرة سيكون كمدى دينامكى يتمدد وينكمش حسب احتواء العمود الاول (A) على بيانات اى اذا كانت الخلايا من (1A) الى (3A) بها بيانات كان المدى عبارة عن 3 صف و 5 أعمدة . اما اذا كانت الخلايا من (1A) الى (7A) بها بيانات كان المدى عبارة عن 7 صف و 5 أعمدة . شئ جميل جدا طبعا لمن يتعامل مع الاكواد وخاصتا من يعمل مع اسماء النطاقات بدل من الاشارة الى المدى بالخلايا المرجعية له 0 اخى قم فتح ملف جديد فارغ لنعمل هذا المثال : قم بتسمية الورقة الاولى Test1 فى الورقة الاولى قم بتحدد المدى (A1:E10) وقم بتلوين خلاياه باللون الاخضر الفاتح ليكون فقط واضح لنا . قف فى اى خلية واضغط مفتاحى (كنترول + اف3) لفتح صندوق الحوار (تعريف اسم) فى خانة (الاسماء فى المصنف) اكتب اسم المدى او النطاق فى هذا المثال وليكن (MyRange) وفى خانة (يشير الى) اكتب الصيغة التالية : سنقوم بشرحا بعد إنشاء المدى والتعرف عليه =OFFSET(Test1!$A$1;0;0;COUNTA(Test1!$A$1:$A$10);5) ثم اضغط موافق وقم بحفظ الملف املئ الخلايا الخضراء بأى بيانات اضغط مفتاح (اذهب الى) اى مفتاح (اف5) و اكتب (MyRange) طبعا بدون الاقواس سنجد ان المنطقة الخضراء تم تعليمها بالكامل (A1:E10) الان قم بمسح بيانات الصف العاشر والتاسع اضغط مفتاح مفتاح (اف5) و اكتب (MyRange) سنجد هنا ان المنطقة المعلمة عبارة عن ثمانية صفوف من الجدول والان امسح محتويات الخلية (8A) اضغط مفتاح مفتاح (اف5) و اكتب (MyRange) سنجد هنا ان المنطقة المعلمة عبارة عن سبعة صفوف من الجدول لماذا اخى سنفهم ذلك من شرج صيغة المدى : =OFFSET(Test1!$A$1;0;0;COUNTA(Test1!$A$1:$A$10);5) لاحظ ان Test1! هذا هو اسم اورقة الاولى ملحق به علامة التعجب ليشر الى اسم الورقة (هذه طريقة الاشارة الى اسماء الاوراق فى صيغ المعادلات) 1 - العامل الاول : Test1!$A$1 وهو يشير الى الخلية (1A) فى الورقة ( Test1 ) اى الخلية الاساسية او نقطة بداية المدى او خلية الارتكاز او الخلية الام 2 - العامل الثانى : صفر 3 - العامل الثالث : صفر العامل الثانى والثالث صفر لأننا لن نبتعد عن الخلية الام بأى عدد من الخلايا لا رأسيا او افقيا 4 - العامل الرابع : COUNTA(Test1!$A$1:$A$10) هذا العامل هو قلب المدى المتحرك او الديناميكى او المفصلى فهو يقوم بعد الخلايا فى العمود الاول من (A1) الى (A10) . فعندما قمنا بمسح بيانات الصف الصف العاشر والتاسع كان ناتج هذا العامل هو 8 أى 8 صفوف وهو العامل الديناميكى فى الصيغة . وايضا عندما قمنا بمسح محتويات الخلية (A8) كان ناتج هذا العامل هو 7 أى 7 صفوف وهنا بيت القصيد . لان ارتفاع الجدول او المدى (MyRange) يتحدد حسب احتواء المدى (A1: A10) على بيانات . 5- العامل الخامس : 5 وهنا نقوم بتحديد عرض الجدول او المدى (MyRange) بعدد من الاعمدة وهو 5 أعمدة وهو ثابت دائما . ولكن يمكن جعله ديناميكى ايضا لو اردنا ذلك بنفس الطريقة المتبعة فى العامل الرابع ليكون جدول متحرك او ديناميكى كامل الاحساس بالنسبة لعدد صفوف واعمدة الجدول ولكن فى مثالنا هذا هو يتحسس فقط عدد الصفوف بالتحكم فى العامل الرابع ولو اردنا ان يكون كامل الاحساس يجب ان يكون العامل الخامس مفصلى ايضا كالرابع مع تغير عناوين الخلايا الى العناوين المناظرة . لعلى وعسى ان اكون قد وفقت فى شرح المدى الديناميكى وقد تعمدت الاسهاب فى الشرح بطريقة مبسطة لما له من اهمية فى عالم الاكواد وتسهيل العمل المراد انجازة بطريقة فعالة وحية تجاة التغيرات فى حجم المدى المحتوى على بيانات . مع تحيات ابوتامر

الأخت صفاء أتمنى أن يكون البرنامج قد أعجبك، ولقد أرفقت لكي برنامج صغير يمكنكي من فهم ما تم برمجته في الملف الأصلي، وبالتوفيق للجميع. الأخ mutq2004 شكراً لمرورك ولطريقتك الجميلة في تعبيرك عن الشكر. 7sab_al3mr.rar

بطئ جدا ولكن للضرورة أحكام ...... بالإضافة إلى الوصلة الرائعة التى أشار إليها الأخ الفاضل الفدعانى: إليكم كود لفتح الملف فى حالة نسيان كلمة السر - حتى 16 حرف Sub OpenWithPWord() Dim I01 As Integer, I02 As Integer, I03 As Integer, I04 As Integer, I05 As Integer Dim I06 As Integer, I07 As Integer, I08 As Integer, I09 As Integer, I10 As Integer Dim I11 As Integer, I12 As Integer, I13 As Integer, I14 As Integer, I15 As Integer, I16 As Integer Dim XlsFileName As String, strPassWord As String Dim fd As FileDialog On Error Resume Next Set fd = Application.FileDialog(msoFileDialogOpen) With fd fd.AllowMultiSelect = False If .Show = -1 Then XlsFileName = .SelectedItems(1) Else Exit Sub End If End With If XlsFileName = "" Then Exit Sub Workbooks.Open Filename:=XlsFileName, Password:="", ReadOnly:=False If Err = 0 Then Exit Sub If Err <> 1004 Then MsgBox Err & "xx : " & Error Err.Clear Exit Sub End If For I16 = 31 To 255 For I15 = 31 To 255 For I14 = 31 To 255 For I13 = 31 To 255 For I12 = 31 To 255 For I11 = 31 To 255 For I10 = 31 To 255 For I09 = 31 To 255 For I08 = 31 To 255 For I07 = 31 To 255 For I06 = 31 To 255 For I05 = 31 To 255 For I04 = 31 To 255 For I03 = 31 To 255 For I02 = 31 To 255 For I01 = 32 To 255 ' ********************************** strPassWord = Chr(I01) _ + IIf(I02 > 31, Chr(I02), "") + IIf(I03 > 31, Chr(I03), "") + IIf(I04 > 31, Chr(I04), "") _ + IIf(I05 > 31, Chr(I05), "") + IIf(I06 > 31, Chr(I06), "") + IIf(I07 > 31, Chr(I07), "") _ + IIf(I08 > 31, Chr(I08), "") + IIf(I09 > 31, Chr(I09), "") + IIf(I10 > 31, Chr(I10), "") _ + IIf(I11 > 31, Chr(I11), "") + IIf(I12 > 31, Chr(I12), "") + IIf(I13 > 31, Chr(I13), "") _ + IIf(I14 > 31, Chr(I14), "") + IIf(I15 > 31, Chr(I15), "") + IIf(I16 > 31, Chr(I16), "") Application.StatusBar = strPassWord Workbooks.Open Filename:=XlsFileName, Password:=strPassWord, ReadOnly:=True If Err.Number = 0 Then Application.StatusBar = False MsgBox strPassWord Exit Sub Else Err.Clear End If ' ********************************** Next I01 Next I02 Next I03 Next I04 Next I05 Next I06 Next I07 Next I08 Next I09 Next I10 Next I11 Next I12 Next I13 Next I14 Next I15 Next I16 End Sub RmvFilePWord.xls