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

وعليكم السلام استاذ مؤمن.. وجدت الملف المرفق في مكتبتي.. عسى ان ينفعك ..وللامانة العلمية اخذته من احد المواقع الاجنبية SerialNumber.mdb

حياالله من يانا وجاب طارينا 🙂 الله يسلمك انت لم تحدد طريقة الاستلام ، وعليه نحدد طريقة الارسال ، واذا قلبك قوي ، ممكن يصلك حالا (ولقد اعذر من انذر) 😲😬 جعفر

هذا معناه انك ما تريد توصيل حالي ، وما مستعجل 😁 جعفر

البحور ممكن نطلبة من شخص على بالي عزيز علينا وعلى المنتدى اول حرف من اسمه @jjafferr

ببساطة تريد عمل فلتر على القيم True , False وكما اشار استاذى القدير @ناقل المرفق بصراحة اتعجب ممن يريد اجابه ولا يريد تعب نفسه بوضع مرفق ويستسهل تعب الاخرين الذين يريدون مساعدته وعلى من يريد تقديم المساعدة ان يحضر البخور العمانى ويضرب الودع ليفهم الية العمل وطريقة التفكير التى تمت بها القاعدة وللاسف ما عندى بخور عمانى الان

اتصل بصاحب البرنامج ....

تفضل هذا الكود فقط ضع مسار قاعدة البيانات و سيتم انشاء نسخة مماثلة منها دون الحاجة الى فتحها و تمرير كلمة المرور If MsgBox("هل تريد انشاء نسخة احتياطية الآن ؟", vbQuestion + vbYesNo + vbMsgBoxRight, "تأكيد") = vbYes Then Dim MyFile, DstFile As String Dim Syso As Object MyFile = " ضع هنا مسار قاعدة البيانات " DstFile = CurrentProject.Path & "\Backup-" & Format(Now, "dd-mm-yyyy") & "." & Split(Mid(MyFile, InStrRev(MyFile, "\") + 1), ".")(1) Set Syso = CreateObject("Scripting.FileSystemObject") Syso.copyfile MyFile, DstFile Set Syso = Nothing End if

تفضل هذا التعديل sendemail2.zip

تفضل 🙂 لا نستخدم الزر ، وانما نستخدم زر مسك الفأرة : Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'https://stackoverflow.com/a/1670110 'https://stackoverflow.com/a/18793073 'Me.SelHeight = to specify or determine the number of selected rows 'Me.SelTop = to specify or determine which row (record) is topmost in the current selection Dim i As Integer Dim rst As dao.Recordset Set rst = Me.RecordsetClone If Me.SelHeight = 0 Then Exit Sub rst.MoveFirst ' Move to the first selected record. rst.Move Me.SelTop - 1 'its slow to refresh, so don't show it Me.Painting = False For i = 1 To Me.SelHeight rst.Edit rst![MOVEX] = -1 rst.Update rst.MoveNext Next i Me.SelHeight = 0 'unSelect the Records Me.Painting = True 'show the Records values End Sub جعفر 1423.select.accdb.zip

ياباشا اصلا انت كاتب اسامى الحقول بالانجليزى بص هو ممكن تشرح ببساطه انت عاوز توصل لايه بلاش تحط فكرتك انت وتجبرنا نوصلك لـ نتيجة بناء على فكرتك انت لان شكلك انت بتفكر غلط وكده هتجيب لنا جنان اكثر من اللى احنا فيه

ولمزيد من الفائدة استخدم الكود التالي لفصل الارقام عن الحروف Public Function Numtext(fildHrfRqm As String) Dim lets, lets2, lets3 Dim i, r As Integer r = Len(fildHrfRqm) For i = 1 To r lets = Mid(fildHrfRqm, i, 1) If IsNumeric(lets) Then lets2 = lets2 & lets End If Next Numtext = lets2 End Function Debug.Print Numtext(MBSerialNumber) تحياتي

وعليكم السلام ورحمة الله وبكاته تفضل اخي الكريم Public Function MBSerialNumber() As String Dim objs As Object Dim obj As Object Dim WMI As Object Dim sAns As String Set WMI = GetObject("WinMgmts:") Set objs = WMI.InstancesOf("Win32_BaseBoard") For Each obj In objs sAns = sAns & obj.SerialNumber If sAns < objs.Count Then sAns = sAns & "," Next If Right(MBSerialNumber, 1) = "," Then MBSerialNumber = Left(MBSerialNumber, LenB(MBSerialNumber) - 1) MBSerialNumber = sAns End Function Debug.Print MBSerialNumber تحياتي

العفو اخي الكريم تحت امرك في اي وقت

تفضل التعديل A- DATA (3).zip

تفضل If MsgBox("هل تريد انشاء نسخة احتياطية الآن ؟", vbQuestion + vbYesNo + vbMsgBoxRight, "تأكيد") = vbYes Then Dim MyFile, DstFile As String Dim Syso As Object MyFile = " ضع هنا مسار قاعدة البيانات " DstFile = CurrentProject.Path & "\Backup\Backup-" & Format(Now, "dd-mm-yyyy") & "." & Split(Mid(MyFile, InStrRev(MyFile, "\") + 1), ".")(1) Set Syso = CreateObject("Scripting.FileSystemObject") Syso.copyfile MyFile, DstFile Set Syso = Nothing End if

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

موضوع البخور هذا موضوع كبير بينى وبين استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @jjafferr فقط اداعب استاذى وامرح معه لا عليك من موضوع البخور يا دكتور طيب يا دكتور انا تقريبا حليت المشكلة بالمرفق الأخير هل قمت بالتجربة المرفق مرة أخرى من هنا حذف من الفرعى (1).accdb

استاذنا / @jjafferr بعد اذنك استاذى الفاضل / كما اوضح الاستاذ / ابو جودى استاذ / ابو جودى بخور ايه انا مش عارف انت بتتكلم عن ايه

وعليكم السلام 🙂 استخدم هذا الكود للحقول المختارة: UPDATE TAB SET TAB.MOVEX = -1 WHERE ((Not (TAB.MOVEX)=[Forms]![FRM2]![MOVEX])); ويمكنك استخدام UPDATE TAB SET MOVEX = -1 WHERE Not MOVEX=[Forms]![FRM2]![MOVEX] وفي صيغة الكود CurrentDb.Execute "UPDATE TAB SET MOVEX = -1 WHERE Not MOVEX=" & [Forms]![FRM2]![MOVEX] جعفر

لا ما اريد شكر كثيراااااااااااااااااااااا لك ولأصحاب البخور

السلام عليكم ورحمة الله ضع المعادلة التالية فى العمود F =IFERROR(IF(SEARCH("مرتجع";$C2)=0;$D2*$E2;"");"") اما هذه المعادلة فضعها فى العمود G =IFERROR(IF(SEARCH("مرتجع";$C2)>0;$D2*$E2;"");"")

تفضل التعديل A- DATA (3).zip

بما انك قمت بتحويل قاعدة البيانات الى نوع SQL فالآن تستطيع انشاء واجهات بإستخدام ASP OR PHP OR PYTHON و بأي لغة تريدها و انصحك بما انك استطعت بناء مشروع على بئة الأكسس فستجد اقرب و اسهل المشاريع لك هي بيئة عمل vb.ASP في هذا الموقع w3schools ستجد امثلة كثيرة للتصميم ابدء و ان استصعب عليك شيء قم بفتح موضوع جديد في القسم المخصص في موقعنا الغالي اوفيسنا و ستجدني و زملائي متفاعلين معك بإذن الله لكن المهم ان تبدء ابدء بإنشاء Master Page و قم بإضافة الصفحات حسب الحاجة اليها

السلام عليكم ورحمة الله اليك الكود الثانى Sub AddCircles2() Dim Shp As Shape, ws As Worksheet Dim i As Long, j As Long, p As Long Dim C As Range, x As Integer, y As Integer 'DelShap Set ws = Sheets("ورقة1") x = ws.Range("W1").Value i = 13 Do While i <= 20 j = 5 For Each C In ws.Range(Cells(j, i), Cells(13, i)) On Error Resume Next y = InStr(C.Value, "/") If C.Value <> "" And y > 0 Then Set Shp = ActiveSheet.Shapes.AddShape(msoShapeOval, _ C.Left, C.Top, C.Width, C.Height) p = p + 1 Shp.Fill.Visible = msoFalse Shp.Line.Weight = 1.5 Shp.Line.ForeColor.SchemeColor = 10 If p >= x Then Exit Sub End If Next j = j + 2 i = i + 1 Loop End Sub

السلام عليكم 🙂 وهنا ستجد طرق اخرى جعفر

السلام عليكم 🙂 ما شاء الله ، عمل جميل 🙂 جعفر

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

انتم الأجمل أستاذي الجليل ومعلمي القدير و والدى الحبيب أستاذ @ابوخليل نعم استاذى وكذلك المرفق الأخير هذا يدعم كلتا النواتان 32 , 64 كذلك فقط هذا الاخير الذى اشرت اليه يعتمد على مكتبة جافا وملفات الـ dll الخاصة بها نعم أستاذي الجليل وذلك لما احسسته من صعوبة وعناء بعض أحبابي في طريقة تسجيل المكتبة لذلك اشرت في رأس الموضوع الى كل الموضوعات السابقة لتكون مجمعة في هذا الموضوع ليكون بمثابة البستان وليقطف منه كل من يريد ما تشتهيه نفسه من خلال متابعتي لأحبابي وردهم على المشاركات السابقة ونظرا لأهمية الموضوع حتى وأن البعض من احبابنا أراد أداة تسهل عملهم أمعنت النظر ليخرج بأبسط ما يمكن واقل تعقيد ليخدم الجميع... فقط لوجه الله تعالى جزانا الله وإياكم وكل المسلمين خيرا ان شاء الله فعلا الموضوع كان متعب جدا جدا جدا وتقريبا ظللت بدون نوم لفترات كبيرة بسببه.. ولكن من كان يهمهم هذا الموضوع اهميتهم عندي اكبر وانت على رأسهم أستاذي الجليل وفى النهاية الحمد لله تعالى الذى هدانا وما كنا لنهتدي لولا ان هدانا الله عزوجل فذلك فضل الله الذى تتم بنعمته الصالحات سبحانك اللهم لا علم لنا الا ما علمتنا انك انت العليم الحكيم

ضع الكود الاتى قى الاستعلام مع تغيير اسم الجدول TblName باسم الجدول تبعك MyNum: DCount("ID","TblName","ID <=" & [ID])

السلام عليكم ورحمة الله تعالى وبركاته بعد جلسات العمل والنقاش هذه وأيضا تلك وأيضا تلك وأيضا تلك واخص فيها أستاذي الجليل ومعلمي القدير و والدى الحبيب أستاذ @ابوخليل له كل الشكر والتقدير وكذلك أصحاب المواضيع الذين حثوا الهمم لإخراج مثل هذا العمل اهداء الى منتدانا الحبيب واحبابنا الكرام اليكم كود الاستجابة السريع QR CODE (يدعم اللغة العربية) حسب متطلبات هيئة الزكاة والضريبة والجمارك السعودية علما انه يتم قراءة الرمز عبر قارىء خاص بالهيئة ( تطبيق جوال ) حمل من هنا : تطبيق هيئة الزكاة والضريبة والجمارك كما يتم قراءة الرمز عبر قارىء خاص من خلال موقع على الانترنت إذهب الى الموقع : من هنا الشرح ... مهم جدا مفيش أي شرح متطلبات التشغيل كالتالي : فقط يرجى التأكد من وجود الأداة qr.exe داخل مجلد باسم Reference في نفس مسار قاعدة البيانات اسالكم الدعاء بظهر الغيب لصديقي في العمل و الذى ساعدني في عمل ملف qr.exe أتمنى لكم تجربة ممتعة ... ================================================== KSA E-Invoicing QR-Code.zip

تفضل أخي محمود : طباعة تقرير بشرط.rar

السلام عليكم ورحمة الله تم التعديل ليعمل على خلايا الفصول فقط Sub AddCircles1() Dim Shp As Shape Dim i As Long, j As Long, p As Long Dim C As Range, x As Integer, y As Integer DelShap x = Range("V1").Value i = 10 Do While i >= 6 j = 5 Do While j <= 13 For Each C In Range(Cells(j, i), Cells(13, i)) On Error Resume Next y = InStr(C.Value, "/") If C.Value <> "" And y > 0 Then p = p + 1 Set Shp = ورقة1.Shapes.AddShape(msoShapeOval, _ C.Left, C.Top, C.Width, C.Height) Shp.Fill.Visible = msoFalse Shp.Line.Weight = 1.5 Shp.Line.ForeColor.SchemeColor = 10 If p >= x Then Exit Sub End If Next i = i - 1 Loop j = j + 2 Loop End Sub

تسلم بارك الله فيك وجزاك الله خير فى الدنيا والاخرة ويا مسهل ربنا يسترها مش اتوه انا

جرب هذا الملف لعله يكون المطلوب معادلة تجميع الإجماليات.xls

تفضل التعديل A- DATA (3).zip

تحياتى استاذ @حسين العربى

تفضل أخي .. إشراف (1).accdb

وعليكم السلام ورحمة الله وبركاته هل تقصد بالأسطر الفقرات؟ أي هل تريد حذف الفقرات الفارغة؟ وكذلك حذف الفقرات المتشابهة؟

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

الاخوة الزملاء بناء على سؤال على اليوتيوب ربط خلية في ورقة اكسل لفتح ملف من نوع word ممكن فتح اى ملف غير الورد بعد وضعة فى الفولدر وتغير صيغة الملف كما فى الصورة فتح ملفات pdf ستجد اسفل الموضوع فتح ملف ورد.rar

فتح ملفاتpdf مع ملفين للقران الكريم للاستفادة منهم رابط الملف

الى جميع الاخوى الاعضاء اضع بين ايدكم في منتدانا الكريم على ال جميع بلمعلومات ملف عله نستفيد منه والعطاء لله ومن الله تكرمون وتقبلو تحياني local_month_and_day_names.rar

أخي الحبيب صلاح أنا بقالي يومين بحاول أشوف الموضوع فين .. يظهر العفاريت عملوها فينا وأخفوا الموضوع عموماً كنت قد طلبت الطريقة ووجب علي أن أقدمها لك خصوصاً بعد انتظار أسبوع الموضوع والحل الذي لدي في قمة البساطة والسهولة .. وأنا خايف تشتم بعد ما تعرف الطريقة (فعايز وعد منك من غير شتيمة) الحل بدون أكواد على الإطلاق المصنف اللي فيه الصور المراد استخراجها غير امتداده من xlsm إلى zip .. وروح اعمل كليك يمين عليه واعمل Extract أي استخراج للملفات .. هيطلع لك من ضمن المستخرج مجلد اسمه Media ودا جواه الصور بنفس التنسيق ونفس الحجم تماماً وسلم لي على التروماي .. ومش عاااااااااااااايز شتيمة تقبل وافر تقديري واحترامي

السلام عليكم أساتذتى واخوانى بالمنتدى تناولت فى موضوعى السابق طريقة نقل بيانات من ملف مغلق الى ملف مغلق أخر بطريقة تسمى ado وهى اختصار للعبارة ActiveX Data Objects بدأ العمل بها فى مايكروسوفت 1996 تستخدم هذة الطريقة فى ترحيل ونقل البيانات بين الملفات استخدمت هذه الطريقة فى جلب البيانات الى شيت رئيسى ثم ربطت الشيت الرئيسى بشيت آخر بلينك . بعد ذلك قلت لنفسى لو عندى كود لادخال البيانات الى ملف مغلق يبقى الأمر 10/ 10 ثم بحث عن كود ووجدت واحد فى أحد المواقع الأجنبية وقمت بتعديله بطريقة لا يشعر فيها المستخدم بأن الملف ده اتفتح والتفاصيل هنا : http://www.officena.net/ib/index.php?showtopic=57798 والحمد لله تم استبدال اللينك بكود . وتركت لكم الملفات فى الرابط ده . مرة مستخدما اللينك ومرة الكود فى ادخال البيانات للملف المغلق . و اليوم أقدم لكم كيفية جلب البيانات من 3 ملفات مغلقة دفعة واحدة وبضغطة زر واحدة ومن ثم ترحيلها وادخالها الى ملف مغلق آخر دون شعور المستخدم بذلك وهذا يتم بذات الطريقة السابقة . للأصدقاء من خارج المنتدى : على الميديا فاير من خلال الرابط التالى http://www.mediafire.com/download/gidslzjdssb2jii/copy__data_from_a_closed_excel_file__&_paste_it_in_a_closed_excel_file_by_mokhtar_(__3_).rar للأصدقاء فى المنتدى : تفضلوا الملفات فى المرفق التالى . أرجوا أن يفيدكم وتستمتعوا به تحياتى للجميع copy data from 3 closed excel file & paste it in a closed excel file by mokhtar ( 3 ).rar

الأخ الفاضل أبو تريكة جرب الكود بهذا الشكل Sub GetData_Example3() GetData ThisWorkbook.Path & "\1.xlsx", "1", _ "A1:t26", Sheets("1").Range("A1"), False, True GetData ThisWorkbook.Path & "\2.xlsx", "1", _ "A1:t26", Sheets("1").Range("A27"), False, True GetData ThisWorkbook.Path & "\3.xlsx", "1", _ "A1:t26", Sheets("1").Range("a53"), False, True End Sub تم تغيير كلمة True قبل الأخيرة إلى False لأنه بارامتر يتعامل مع العنوان .. فإذا كان للبيانات عنوان في الملف المراد جلب البيانات منه .. جعلت القيمة True أما إذا لم تكن البيانات لها عنوان فتقوم بجعل القيمة False أرجو أن تكون تلك النقطة هي حل المشكلة تقبل تحياتي

السادة / أعضاء منتدي أوفسينا حفظهم الله نتيجة لقيامي بعمل بعض التعديلات على الملف بناء على طلب بعض الاخوة في المنتدي و قد قمت بعمل هذه التعديلات و بعد مراجعتي للملف ظهرت بعض المشاكل بناء علية قمت بتعديلها كاملا وقد عملت على اضافة بعض الميزات التى يمكن لكم الاستفادة منها في اعمالكم اضافة شاشة دخول جديدة بها ميزات جميلة مثل شريط متحرك تتحكم في سرعة الحركة أو توقيفها و العودة لها مرة اخري بالاضافة الي الصفحة الرئيسية بالملف بها شريط متحرك ايضا بشكل جديد و جميل يمكن لك التحكم باللون و الخط و الخلفية أرجو أن أكون قد وفقت المرفقات:- -------- FINAL DATA_khaled.rar --------

Create Index page with hyperlinks to sheets Sub CreateIndex() Dim wSheet As Worksheet Dim l As Long l = 1 With Me .Columns(1).ClearContents .Cells(1, 1) = "INDEX" .Cells(1, 1).Name = "Index" End With For Each wSheet In Worksheets If wSheet.Name <> Me.Name Then l = l + 1 With wSheet .Range("A1").Name = "Start" & wSheet.Index .Hyperlinks.Add Anchor:=.Range("A1"), Address:="", SubAddress:= _ "Index", TextToDisplay:="Go to Index Page" ' Change "A1" in the line above to the cell address where you want to put link to Index page End With Me.Hyperlinks.Add Anchor:=Me.Cells(l, 1), Address:="", SubAddress:="Start" _ & wSheet.Index, TextToDisplay:=wSheet.Name End If Next wSheet End Sub

Export Excel Charts to PowerPoint Option Explicit Function getPPPres() As PowerPoint.Presentation Dim PPApp As PowerPoint.Application 'Reference instance of PowerPoint On Error Resume Next 'Check whether PowerPoint is running Set PPApp = GetObject(, "PowerPoint.Application") If PPApp Is Nothing Then 'PowerPoint is not running, create new instance Set PPApp = CreateObject("PowerPoint.Application") 'For automation to work, PowerPoint must be visible PPApp.Visible = True End If On Error GoTo 0 'Reference presentation and slide On Error Resume Next If PPApp.Windows.Count > 0 Then 'There is at least one presentation 'Use existing presentation Set getPPPres = PPApp.ActivePresentation Else 'There are no presentations 'Create New Presentation Set getPPPres = PPApp.Presentations.Add End If Set PPApp = Nothing End Function Function getNewSlide(PPPres As PowerPoint.Presentation) As PowerPoint.Slide Set getNewSlide = PPPres.Slides.Add(PPPres.Slides.Count + 1, ppLayoutBlank) End Function Sub ExportChartsToPPT(wksChartsFromSheet As Worksheet) Dim PPPres As PowerPoint.Presentation Dim PPSlide As PowerPoint.Slide Dim cht As ChartObject If wksChartsFromSheet.ChartObjects.Count = 0 Then MsgBox "No Chart to Export to Powerpoint", vbInformation, "" Exit Sub End If Set PPPres = getPPPres ' If PPPres.Slides.Count = 0 Then ' Set PPSlide = getNewSlide(PPPres) ' End If For Each cht In wksChartsFromSheet.ChartObjects Set PPSlide = getNewSlide(PPPres) cht.CopyPicture PPSlide.Select PPSlide.Shapes.Paste.Select PPSlide.Application.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True PPSlide.Application.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True PPSlide.Select Next cht Set cht = Nothing Set PPSlide = Nothing Set PPPres = Nothing End Sub Sub TestExecute() Call ExportChartsToPPT(Sheet2) End Sub

أولا أساتذتى واخوانى السلام عليكم ورحمة الله وبركاته ثانيا بارك الله فييك اخى j011 ثالثا : أشكرك أستاذى الكريم ياسر خليل على مروك الكريم وتشجيعك لى وتنفيذا لتوجيهاتك أقدم للزملاء شرحا مبسطا : بعد ما نوحد ربنا ونصلى على المصطفى صللى الله عليه وسلم الموضوع حضراتكم فيه ثلاث أفكار يمكن تطبيقها 1 - نسخ أو جلب أو ترحيل بيانات من ملف مغلق واحد 2 - نسخ أو جلب أو ترحيل بيانات من أى عدد من الملفات المغلقة . 3- - ادخال بيانات الى ملف مغلق ( بطريقة لا تشعر فيها بأنه تمت عملية نسخ الى هذا الملف تماما مثل البرامج التى تعمل فى الخلفيه دون شعور المستخدم ) 1-الكود التالى نضعه فى حدث الـــــــ Workbook بتاع الملف المغلق اللى هننقل منه البيانات Private Sub Workbook_BeforeClose(Cancel As Boolean) ActiveWorkbook.Save Application.Quit End Sub الكود يعمل على حفظ البيانات التى كتبناها فى الملف المغلق الذى نريد النقل منه كما أنه يغلق الاكسل بدون تدخل منك . **************************************************************************************** الكودان التاليان نضع كلا منهما ا فى مديول عادى فى الملف اللى هنحط فيه البيانات التى أخذناها من الملف المغلق وهما معا أحد تطبيقات نظام ado فلى نقل البيانات الكود الأول : نضعه كما هو بدون تتغيير : Public Sub GetData(SourceFile As Variant, SourceSheet As String, _ SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean) Dim rsCon As Object Dim rsData As Object Dim szConnect As String Dim szSQL As String Dim lCount As Long ' Create the connection string. If Header = False Then If Val(Application.Version) < 12 Then szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & SourceFile & ";" & _ "Extended Properties=""Excel 8.0;HDR=No"";" Else szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & SourceFile & ";" & _ "Extended Properties=""Excel 12.0;HDR=No"";" End If Else If Val(Application.Version) < 12 Then szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & SourceFile & ";" & _ "Extended Properties=""Excel 8.0;HDR=Yes"";" Else szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & SourceFile & ";" & _ "Extended Properties=""Excel 12.0;HDR=Yes"";" End If End If If SourceSheet = "" Then ' workbook level name szSQL = "SELECT * FROM " & SourceRange$ & ";" Else ' worksheet level name or range szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];" End If On Error GoTo SomethingWrong Set rsCon = CreateObject("ADODB.Connection") Set rsData = CreateObject("ADODB.Recordset") rsCon.Open szConnect rsData.Open szSQL, rsCon, 0, 1, 1 ' Check to make sure we received data and copy the data If Not rsData.EOF Then If Header = False Then TargetRange.Cells(1, 1).CopyFromRecordset rsData Else 'Add the header cell in each column if the last argument is True If UseHeaderRow Then For lCount = 0 To rsData.Fields.Count - 1 TargetRange.Cells(1, 1 + lCount).Value = _ rsData.Fields(lCount).Name Next lCount TargetRange.Cells(2, 1).CopyFromRecordset rsData Else TargetRange.Cells(1, 1).CopyFromRecordset rsData End If End If Else MsgBox "No records returned from : " & SourceFile, vbCritical End If ' Clean up our Recordset object. rsData.Close Set rsData = Nothing rsCon.Close Set rsCon = Nothing Exit Sub SomethingWrong: MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _ vbExclamation, "Error" On Error GoTo 0 End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Function Array_Sort(ArrayList As Variant) As Variant Dim aCnt As Integer, bCnt As Integer Dim tempStr As String For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1 For bCnt = aCnt + 1 To UBound(ArrayList) If ArrayList(aCnt) > ArrayList(bCnt) Then tempStr = ArrayList(bCnt) ArrayList(bCnt) = ArrayList(aCnt) ArrayList(aCnt) = tempStr End If Next bCnt Next aCnt Array_Sort = ArrayList End Function الكود الثانى : ده توأم السابق يتعاونان معا فى سحب البيانات من الملف المغلق لكن الكود ده هو اللى هنلعب بيه الكورة ونغير فيه بكل سهوله وأريحيه Sub GetData_Example1() ' السطر الاول بنقول للكود هات البيانات من الملف المغلق الفلانى/ الشيت الفلانى ' السطر الذى يليه بنقول للكود انسخ المدى الفلانى من الشيت الفلانى 'وكمان الصق الكلام ده فى الخليه الفلانيه GetData ThisWorkbook.Path & "\mokhtar1.xls", "Sheet1", _ "A1:C5", Sheets("Sheet1").Range("AA1"), True, True ActiveWorkbook.Save Application.Quit End Sub ملحوظة مهمه فى الكود السابق :بص كده على الكلمتين دول True, True الكلمة الاخيرة تخلى الكود يظهر راس الصفحة ( لاحظ ذلك فى مرفق الموضوع ) أما لوكتبناهم بالشكل ده True, false رأس الصفحة مش هييجى ضمن البيانات التى أخدناها من الملف المغلق ايضا لاحظ هنا أننا بنا خد البيانات بتاعتنا من ملف اكسل مغلق واحد وبكده نكون خلصنا الفكرة الأولى . بعد ما خلصت الفكرة الاولى اخوانى شعرت بأنه لو يمكن ادخال البيانات الى ملف مغلق تبقى العمليه ايه !!!!!!!! ومن هنا ظهرت الفكرة الثانية الفكرة الثانيه : هى ادخال بيانات الى ملف مغلق طبعا ليس من المعقول ادخال البيانات الى ملف مغلق دون فتحه لذلك بحثت مرارا وتكرارا عن كود يفتح الملف المغلق وجربت أكتر من كود لحد ما عثرت على واحد سهل وحسيت منه أننى أستطيع تعديله وبالفعل تم الامر لى بعون الله وتوفيقه انظر الى الموضوع التالى : http://www.officena.net/ib/index.php?showtopic=57798 الكود ده غيرت فيه بحيت يفتح الملف ووتدخل البيانات بسرعة من غير ما حد يحس ان فيه حاجه حصلت وهذا هو الكود Sub export_data() Dim mokhtar2 As Workbook Dim mokhtar3 As Workbook Application.ScreenUpdating = False Set mokhtar2 = ActiveWorkbook Set mokhtar3 = Workbooks.Open("C:/TEMP/mokhtar3.xls") mokhtar2.Sheets(1).Range("A1:C5").Copy With mokhtar3.Sheets(1).Range("A1") .PasteSpecial xlValues .PasteSpecial xlFormats End With Application.Quit End Sub الكود السابق نضعه فى مديول عادى فى الملف اللى هنرحل منه الى الملف المغلق اللى هو فى الأصل الملف اللى بستورد اليه البيانات من الملف المغلق ( الملف الرئيسى ) الكود معناه : بنصرح للبرنامج ان مختار 2 ومختار 3 دول اعتبرهم Workbook ونشط لى مختار 2 وانسخ المدى a1 : c5 منه وطيران على المجلد temp اللى فى الــــ c هتلاقى هناك الملف المغلق مختار 3 افتحه وقله مختار 2 بيسلم عليك وباعتلك شويه البيانات دول بمناسبة المولد النبوى ورأس السنة الميلادية وقله لو سمحت يا عمو حطهم فى الخلية a1 ومتنساش تقفل الباب وراك يلا بسرعة كده ومن غير ما حد يحس بيك . وبكه نكون خلصنا من الفكرة الثانيه . ************************************************************ الفكرة الثالثه : وليدة الفكرة الأولى الا انها تقوم على النسخ من عدد غير محدود من الملفات المغلقه ( 2 3 4 5 6 7 ........) بعكس الفكرة الأولى التى ننسخ فيها بيانات من ملف مغلق واحد فقط والكود التالى يمثل النقل من 3 ملفات مغلقة mokhtar1 mokhtar2 mokhtar3 Option Explicit Sub GetData_Example3() 'السطران التاليان خاصان بالنسخ من الملف المغلق مختار 1 ' True, True لاحظ فيهما الكلمتين GetData ThisWorkbook.Path & "\mokhtar1.xls", "Sheet1", _ "A1:C12", Sheets("Sheet1").Range("A1"), True, True 'السطران التاليان خاصان بالنسخ من الملف المغلق مختار 2 GetData ThisWorkbook.Path & "\mokhtar2.xls", "Sheet1", _ "a2:c11", Sheets("Sheet1").Range("A13"), True, True 'السطران التاليان خاصان بالنسخ من الملف المغلق مختار 3 GetData ThisWorkbook.Path & "\mokhtar3.xls", "Sheet1", _ "E1:E23", Sheets("Sheet1").Range("E1"), True, True 'وبنفس الكيفية يمكنك زيادة عدد الملفات المغلقة End Sub ' وسلام الله عليكم ورحمته وبركاته .

السلام عليكم إليك حل نهائي (باستخدام نفس فكرة أخي أبو أسامة جزاه الله خيرا) الملف المرفق الشرط الوحيد أن يكون الملف الإكسل مع الملفات الــ PDF المراد فتحها في مجلد (فولدر) واحد تفضل وجرب وطبعا ممكن تغير أسماء الملفات الــ PDF Link_Pdf.rar