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

احي مصطفى لا داعي للسطر الذي قلت عنه لانه في الكود مذكور أن يتجاوز الخلايا الفارغة ) المطلوب فقط ان تترك الخلية فارغة ولا يتم وضع لا " 0" ولا " -" ولا اي شيء آخر يتم ادراج فقط ارقام من 1 الى نهاية الشهر حسب الخلية المناسبة في العامود C يتوسط الرقمين "-" للتوضيح هذه الصورة

السلام عليكم, في سنة 2017 قمت بكتابة كلاس بسيط لحماية برنامجي ولضمان برنامجي لا يعمل في غير كومبيوترات في حاله بيعه. مميزات الكلاس: 1- قفل قاعدة البيانات على ( رقم الهارد , البروسيسور , المذربورد , الماك أدريس ) 2- (استحاله) فك النماذج والتقارير في حال عدم تجاوزك لنموذج ( تسجيل الدخول ) ببساطة ستقول يمكنني العثور على باسورد القاعدة داخل الجدول ( الطريقة المعتادة لدينا جميعا في انشاء نموذج تسجيل دخول ). قبل كل شي ليكن لدينا مثلا جدول اسمة ( tbl_Login ) و نموذج اسمه ( frm_Login ) الجدول لتخزين اسم المستخدم وكلمة المرور والنموذج لعمل تسجيل الدخول عند ذهابنا للجدول ( tbl_Login ) ، سوف نحصل على باسورد مشفر من الجدول لو كان الباسورد مثلا ( 313 ) فإنك ستحصل على ( 701D6068 ) 2- عندما نقوم بتسجيل الدخول في النموذج سيقوم البرنامج بأخذ كلمة السر المدخلة ويقوم بتشفيرها ثم يقوم بمطابقتها مع الباسورد الموجود في الجدول اذا كان الباسورد المُدخل يطابق الجدول سيكتب قيمة معينة runtime ويقوم بازالة جميع القيود من النماذج والتقارير. اولا: كلاس الحماية Option Compare Database '----------------------------------------------------- ' Protection Module Coded By Hassanein Hirz Aldeen (SEMO.Pa3x) ' Date 26/11/2017 ' All rights reserved. copyright © 2017 '----------------------------------------------------- Public SEMO As String Function SEMO_GET() SEMO = SEMO SEMO_GET = SEMO End Function Function PR() As Boolean PR = False 'False=Disabled , True=Enabled End Function Function HWND_ID() HWND_ID = "3C3F4825" 'Your HWID End Function Function HWND_MSG() HWND_MSG = "...ليست لديك صلاحيات كافية لإستخدام هذا الاجراء" End Function Function KEY_ENDE() KEY_ENDE = "PA$X" End Function Function HWND_GET() Set root = GetObject("winmgmts:{impersonationlevel=impersonate}!\\.\root\cimv2") Set disks = root.execquery("select * from win32_logicaldisk") For Each disk In disks If disk.volumeserialnumber <> "" Then HWND_GET = disk.volumeserialnumber Exit For End If Next End Function Function HWND_PROTECTION() Set root = GetObject("winmgmts:{impersonationlevel=impersonate}!\\.\root\cimv2") Set disks = root.execquery("select * from win32_logicaldisk") For Each disk In disks If disk.volumeserialnumber <> "" Then HWND_PROTECTION = disk.volumeserialnumber Exit For End If Next If HWND_ID = HWND_PROTECTION Then HWND_PROTECTION = "True" Else HWND_PROTECTION = "False" End If End Function 'Code contained within module named mdlforencryptionanddecryption Public Function XORDecryption(CodeKey As String, DataIn As String) As String Dim arkdata1 As Long Dim strDataOut As String Dim intXOrValue1 As Integer Dim intXOrValue2 As Integer For arkdata1 = 1 To (Len(DataIn) / 2) 'The first value to be XOr-ed comes from the data to be encrypted intXOrValue1 = Val("&H" & (Mid(DataIn, (2 * arkdata1) - 1, 2))) 'The second value comes from the code key intXOrValue2 = Asc(Mid(CodeKey, ((arkdata1 Mod Len(CodeKey)) + 1), 1)) strDataOut = strDataOut + Chr(intXOrValue1 Xor intXOrValue2) Next arkdata1 XORDecryption = strDataOut End Function Public Function XOREncryption(CodeKey As String, DataIn As String) As String Dim arkdata1 As Long Dim strDataOut As String Dim temp As Integer Dim tempstring As String Dim intXOrValue1 As Integer Dim intXOrValue2 As Integer For arkdata1 = 1 To Len(DataIn) 'The first value to be XOr-ed comes from the data to be encrypted intXOrValue1 = Asc(Mid$(DataIn, arkdata1, 1)) 'The second value comes from the code key intXOrValue2 = Asc(Mid$(CodeKey, ((arkdata1 Mod Len(CodeKey)) + 1), 1)) temp = (intXOrValue1 Xor intXOrValue2) tempstring = Hex(temp) If Len(tempstring) = 1 Then tempstring = "0" & tempstring strDataOut = strDataOut + tempstring Next arkdata1 XOREncryption = strDataOut End Function الاستخدام لكل النماذج والتقارير اكتب في حدث Form_Load Option Compare Database Private Sub Form_Load() On Error Resume Next If HWND_PROTECTION = "False" Then MsgBox HWND_MSG, vbCritical, "عملية خاطئة" For i = 0 To Controls.Count - 1 Dim X As Control Set X = Me.Controls.Item(i) X.Visible = False Next DoCmd.Close DoCmd.CloseDatabase DoCmd.Quit End If If Protection.SEMO_GET = "SEMO" = False Then MsgBox HWND_MSG, vbCritical, "عملية خاطئة" For i = 0 To Controls.Count - 1 Dim XS As Control Set XS = Me.Controls.Item(i) XS.Visible = False Next DoCmd.Close DoCmd.CloseDatabase DoCmd.Quit End If End Sub الان عندما تريد اعطاء القاعدة لشخص ما قم باعطاءه اولا ملف الـ VBS هذا '----------------------------------------------------- ' ReCoded By Hassanein Hirz Aldeen (SEMO.Pa3x) ' Date 26/11/2017 ' All rights reserved. copyright © 2017 '----------------------------------------------------- ' Get clipboard text Set objHTML = CreateObject("htmlfile") Set Ws = CreateObject("WScript.Shell") Clipboardtext = objHTML.ParentWindow.ClipboardData.GetData("text") sText = HWND_GET 'Set Clipboard Ws.Run "mshta.exe ""javascript:clipboardData.setData('text','" & Replace(Replace(sText, "\", "\\"), "'", "\'") & "');close();""", 0, True MsgBox "Copied!" Function HWND_GET() Set root = GetObject("winmgmts:{impersonationlevel=impersonate}!\\.\root\cimv2") Set disks = root.execquery("select * from win32_logicaldisk") For Each disk In disks If disk.volumeserialnumber <> "" Then HWND_GET = disk.volumeserialnumber Exit For End If Next End Function وظيفة هذا الملف يقوم باستخراج ( رقم الهارد , البروسيسور , المذربورد , الماك أدريس ) ثم ينسخه بعدما يشغله سيقوم العميل باعطاءك هذا الرقم لكي تقوم انت بدورك بوضعه داخل الكلاس في المنطقة Function HWND_ID() HWND_ID = "Your HWID" End Function استبدل كلمة ( Your HWID ) بالرقم الذي سيعطيه لك العميل. ثم بعد ذلك قم بحفظ القاعدة بصيغة ( ACCDE ) واتحدا اي شخص يفتحها مرة اخرى: لكي تفتح النماذج والتقارير عليك بتخطي نموذج تسجيل الدخول ارفقت لكم قاعدة محمية وقاعدة بدون حماية مع ملف الـ VBS الذي يستخرج ارقام قطع الجهاز ويقوم بنسخها،، اتمنى لكم الفائدة جميعاً اهداء الموضوع الى مُعلمي الرائع @jjafferr حسنين Login_SEMO_Pa3x.rar

فورم استدعاء pdf واظهار البيانات فى الليست اكثر من 10 عواميد وطباعة البيانات الفيديو الصور فورم استدعاء pdf واظهار البيانات فى الليست اكثر من 10 عواميد وطباعة البيانات.rar

الاخوة الزملاء السلام عليكم ورحمة الله وبركاتة برنامج مجاني علي الاكسيل لاقرار ضريبة القيمة المضافة برنامج سهل وبسيط خصائص البرنامج غلق جميع الخلايا التي تحتوي علي معادلات حفظ البيانات بمجرد الخروج العودة للقائمة الرئيسية في كل مرة يتم فتح البرنامج فيها استخدام اوامر الطباعه في الشيت الخاص بالاقرار التقارير إقرار ضريبة القيمة المضافة نموذج10 الخاص بكل شهر التحليل الشهري لفواتير المبيعات والمشتريات تفريغ الاقرارات user : How To Excel password: hte إقرار ضريبة القيمة المضاف 2.0.rar

فورم اكسل لاستدعاء ملفات pdf الفيديو الصور http://www.mediafire.com/file/6qk8jjv5jj2mlyg/pdf++فورم+استدعاء.rar

أترككم مع التجربـة منتظر رأيك يا دكتور @حلبي ولى عودة بعد التجربة text Reader.mdb

أرفق اليكم نموذج بحث متعدد النتائج .. به وحدة نمطية بسيطة لتوحديد الأحرف المتشابهة وإزالة المسافات وتجاهل الهمزات والتشكيل ..عسى يجد من ينتفع به.وتجدر الإشارة أن أغلبه من أفكار رواد هذا المنتدى العزيز. أعزكم الله .. تحياتى Officna.rar

ممكن يكون قصدك هذا اشعار.xlsx

العفو فكلنا نتعلم فالمنتدى في المقام الأول تعليمي

شكرا يا طيب

عليك السلام ورحمة الله وبركاته تم عمل المطلوب ولكن في الاعتبار أن دالة vlookup تظهر العمود الثاني وليس الأول لذلك فقد تم تبديل الأعمدة في شييت3 1.xlsx

السلام عليكم 🙂 هل مشى معاك الحال ابو عبدالله ؟ جعفر

ربما يكون المطلوب هكذا اشعار.xlsx

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

السلام عليكم 🙂 الموضوع كان معقد اكثر مما كنت اعتقد ، وبدأت من جديد اكثر من مرة !! ولكنها خزية تضاف الى شيء اسمه تجربه 🙂 اساس العمل هو استعلام Crosstab ، سهل عمله ، ونتائجه مقبولة 🙂 . . . ولكن لأنك اصررت انك تريد طريقة الجدول ، فأكملنا المشوار من هنا ، بالاستفادة من هذا الاستعلام ، وتحويله الى استعلام إلحاقي ، ليلحق البيانات في الجدول Co_to_Row : . جعلت جميع اسماء الحقول بنفس الطريقة ، والاهم ، اني اضفت حقل الرقم التلقائي: . وتكون البيانات هكذا: . ثم يأتي دور هذا الزر الكبير ، ليقوم بتشغيل الوحدة النمطية ، والتي ستقوم بتعديل البيانات في الجدول . وهذه هي الوحدة النمطية اللتي تقوم بالعمل ، وحاولت ان اجزئها ، واضع الشرح فيها : Public Function ReArrang() '1 Dim rstS As DAO.Recordset Dim rstD As DAO.Recordset Dim RCs As Integer Dim i As Integer Dim N As Integer Dim Co As String Dim jo As String Dim arr_Co() As String Dim arr_jo() As String '2 'append the New data to the Table Co_to_Row DoCmd.SetWarnings False DoCmd.OpenQuery "qry_Append_Co_to_Row" DoCmd.SetWarnings True '3 'we have 8 Areas For N = 1 To 8 '4 'make the field names, based on the loop value Co = "Co" & N jo = "jo" & N '5 'get each set (fields CoX and joX) values Set rstS = CurrentDb.OpenRecordset("Select * From Co_to_Row Where " & Co & " IS NOT NULL") rstS.MoveLast: rstS.MoveFirst: RCs = rstS.RecordCount '6 ReDim arr_Co(RCs) ReDim arr_jo(RCs) '7 'fill the array For i = 1 To RCs '8 arr_Co(i) = rstS(Co) 'Co values arr_jo(i) = rstS(jo) 'jo values '9 'Remove this value from the previous Records rstS.Edit rstS(Co) = "" rstS(jo) = "" rstS.Update '10 rstS.MoveNext Next i '11 Set rstD = CurrentDb.OpenRecordset("Select * From Co_to_Row Order By Auto_ID") '12 For i = 1 To RCs '13 'add this value to fill all Records rstD.Edit rstD(Co) = arr_Co(i) rstD(jo) = arr_jo(i) rstD.Update rstD.MoveNext Next i Next N '14 'Delete the Empty Records DoCmd.OpenQuery "qry_Delete_Empty_Records" '15 rstS.Close: Set rstS = Nothing rstD.Close: Set rstD = Nothing MsgBox "Done" End Function . وهذا استعلام حذف السجلات الفارغة: . والنتيجة النهائية للجدول: . جعفر 1045.col_to_raw.mdb.zip

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

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

لو سمحت تعاود التجربة ، بس الرقم 3 اصبح: https://translate.google.com/#view=home&op=translate&sl=ar&tl=en&text= واذا اشتغل ، استعمل هذا الكود في النموذج بدل الكود الموجود عندك: '.Navigate "https://translate.google.com.eg/?hl=ar&tab=rT#view=home&op=translate&sl=ar&tl=en&text=" & ss .Navigate "https://translate.google.com/#view=home&op=translate&sl=ar&tl=en&text=" & ss جعفر

هاد احلى clock.rar

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

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

السلام عليكم أحبتي أرفقت ملف كشوف المنادة بعد تعديل الأخطاء التي كانت في الملف السابق ..ألتمس العذر منكم . كشوف المناداة وأرقام الجلوس.rar

في الخلية I5 هذه المعادلة ( Ctrl+Shift+Enter) =SUM(--(ISNUMBER(FIND(I$3,$G$5:$G$16)))) tekrar 8yab.xlsm

بارك الله فيك أستاذنا الفاضل والمبدع دائمًا نتعلم من الكثير عمل في غاية الروعة

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

هذا ملف اخر لا يأخذ بعين الاعتبار ما تحتويه الخلايا (فقط ينظر الى الارقام بين 1 و نهاية الشهر) ولا ينظر الى الفواصل اي كانت (فواصل نص * \ / الخ.....) Option Explicit Sub Saerch_date() Dim regex As Object, str As String Set regex = CreateObject("VBScript.RegExp") With regex .Global = True .IgnoreCase = True .Pattern = "([1-3]?\d+)" End With Dim MY_Match, x%, s$, i%, m%: m = 1 Dim Days_num$, Final_Month% Dim my_array() Dim arr_arab(1 To 7) arr_arab(1) = "الأحد": arr_arab(2) = "الإثنين" arr_arab(3) = "الثلاثاء": arr_arab(4) = "الأربعاء" arr_arab(5) = "الخميس": arr_arab(6) = "الجمعة" arr_arab(7) = "السّبت" Range("E5:E16,G5:G16").ClearContents For i = 5 To 16 Set MY_Match = regex.Execute(Range("c" & i)) If MY_Match.Count = 0 Then GoTo next_i For x = MY_Match.Count - 1 To 0 Step -1 Final_Month = Month(DateSerial([E2], i - 4, MY_Match(x))) If Final_Month = i - 4 Then Days_num = Weekday(DateSerial([E2], i - 4, MY_Match(x))) ReDim Preserve my_array(1 To m) my_array(m) = arr_arab(Days_num) m = m + 1 End If Next x Range("E" & i) = m - 1 s = Join(my_array, ",") Range("G" & i) = s s = "": m = 1: Erase my_array next_i: Next Set regex = Nothing Erase arr_arab End Sub الملف مرفق khairi ali_Extra.xlsm

السلام عليكم اخي حلبي 🙂 خلينا نأخذ الخطوات التالية ، ورجاء تأكيد كل خطوة: 1. شغّل اي شيء فيه صوت في الكمبيوتر ، حتى تتأكد ان سماعات الكمبيوتر شغاله ، 2. افتح متصفح الانترنت internet explorer ، 3. ادخل في الموقع (انسخ العنوان الى عنوان المتصفح ، ولا تنقر عليه هنا) https://translate.google.com.eg/?hl=ar&tab=rT#view=home&op=translate&sl=ar&tl=en&text= 4. في الجانب اليمين الصق اي نص تريد (ولكن النص المُفضل هو ما كتبه الباشمهندس محمد 🙂 ) . 5. انقر على السماعة ، واسمع الصوت. واخبرنا النتيجة لوسمحت 🙂 جعفر

رائع أستاذنا الفاضل الأستاذ / سليم أرى أن يتم استبدال العلامة "-" بفاصلة " ,"لأنه أحيانًا لو كان الغياب يومان يتحول إلى تاريخ وقم بتجربتها فكانت بلا مشاكل khairi ali.xlsm

بصراحة يا دكتور لا ادرى ولا اعلم حاولت البحث ولكن لم يهدنى الله الى شئ اسف جدا كنت اتمنى تقديم يد العون

السلام عليكم اكتب الوقت في العمود A ولاحظ النتيجة في العمود B تفضل تحويل الساعة.xlsx

ربما يكون الحل Option Explicit Sub Get_days() Dim i%, k%, m%, it Dim arr(), cont Dim st$ Dim Days_num% Dim arr_arab(1 To 7) arr_arab(1) = "الأحد": arr_arab(2) = "الإثنين": arr_arab(3) = "الثلاثاء" arr_arab(4) = "الأربعاء": arr_arab(5) = "الخميس": arr_arab(6) = "الجمعة" arr_arab(7) = "السّبت" Dim dict As Object m = 1 Set dict = CreateObject("Scripting.Dictionary") For i = 5 To 16 If Range("c" & i) <> "" Then With dict cont = Split(Range("c" & i), "-") .Add i - 4, cont For Each it In .Items ReDim Preserve arr(1 To 1) arr(1) = it Range("e" & i) = UBound(cont) + 1 For k = UBound(cont) To 0 Step -1 Days_num = Weekday(DateSerial([E2], i - 4, cont(k))) st = st & arr_arab(Days_num) & "," Range("g" & i) = Left(st, Len(st) - 1) & "." Next Next .RemoveAll Erase arr st = vbNullString End With End If Next End Sub الملف مرفق khairi ali.xlsm

بارك الله في أستاذنا الفاضل الأستاذ سليم وبعد إذنه تم تعيدل كود التفقيط ليلبي المطلوب order_up_to_100_Salim.xlsm

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

انا اشتغل على اكسس 2010 ، فما في مشكلة 🙂 جرب هذا الملف ، فيه المكتبات المطلوبة فقط ، ولكن لما تنقر على زر "اضغط للقراءة" فيجب ان ترى ان البرنامج قام بتشغيل IE = Internet Explorer . وبعض الاوقات وبسبب سرعة الانترنت ، قد تحتاج تنتظر فترة اطول لسماع الكلام 🙂 جعفر 1043.TTS.mdb.zip

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

السلام عليكم 🙂 وندوز 10 ، ويا ريت تسمع اسمك يا دكتور حلبي ، حتجنن لما تسمع الست تقوله 🙂 جعفر

انا يا دكتور @حلبي استخدم اوفيس 2019 32 بيت وارسلت رسالة بالامس لاحد احبئنا جزاه الله خيرا قام بالتجربة واخبرنى ان القاعدة تعمل معه على اكمل وجه وبأعتذر لحضرتك جدا جدا انا لسة فى اجازة العملية لم اعود الى العمل لذلك لن استطيع التجربة الا على جهازى فقط فى الوقت الراهن

طيب شوف ده كده يا دكتور text Reader.accdb

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

السلام عليكم 🙂 في الماضي كان عندنا معيار واحد فقط (التاريخ) ، بينما الآن اصبح عندنا معيارين (التاريخ و الادارة) ، وهذا اخذ مني اكثر من يومين للوصول اليه !! على العموم ، نظّفت الكود بطريقة اخرى ، والعرض اصبح الآن يأخذ الصفحة كاملة ، وعلى اساسه يعمل عرض الحقول 🙂 وهذا الكود كاملا: Private Sub Report_Open(Cancel As Integer) Dim ctrl As Control Dim A As Integer Dim Empty_Cells As Integer Dim Full_Cells As Integer Dim W As Integer Dim myWhere As String Dim rpt_width As Integer Dim Full_Date As Date Dim D As Integer Dim Y As Integer Dim M As Integer 'W = 2200 / 4 'field width Empty_Cells = 0 Full_Cells = 0 'the name rpt_width = 0 Y = Forms!Report!iYear 'year M = Forms!Report!iMonth 'month 'lets fit/expand the controld based on the avaible width 'how many Full_Cells For D = 1 To 31 Full_Date = DateSerial(Y, M, D) myWhere = "[edara]='" & Forms!Report!cmd_edara_N & "'" myWhere = myWhere & " And " myWhere = myWhere & "[zeiara_date]=" & DateFormat(Full_Date) A = DCount("*", "zeara", myWhere) If A <> 0 Then Full_Cells = Full_Cells + 1 End If Next D W = Me.Width - (Me.Printer.LeftMargin + Me.Printer.RightMargin + Me("mogh_name").Width) W = W / (Full_Cells - 1) For D = 1 To 31 Full_Date = DateSerial(Y, M, D) 'the field Names from the Crosstab query 'check if this field exists int the table myWhere = "[edara]='" & Forms!Report!cmd_edara_N & "'" myWhere = myWhere & " And " myWhere = myWhere & "[zeiara_date]=" & DateFormat(Full_Date) A = DCount("*", "zeara", myWhere) If A = 0 Then 'field dose not exist Me("txt_" & D).Width = 0 'trim field size to Zero Me("txt_" & D).Visible = False 'make the field invisible Me("txt_" & D).ControlSource = "" 'remove the Control Source Me("lbl_" & D).Width = 0 'trim label size to Zero Me("lbl_" & D).Visible = False 'make the label invisible Empty_Cells = Empty_Cells + 1 'Debug.Print "Off " & Me("txt_" & D).Name & vbTab & "D:" & D & vbTab & "Full:" & Full_Date & vbTab & "A:" & A Else 'field exists Me("txt_" & D).Width = 1 * W 'set the field width Me("txt_" & D).Visible = True 'make the field visible Me("txt_" & D).ControlSource = Full_Date Me("lbl_" & D).Width = 1 * W 'set the label width Me("lbl_" & D).Visible = True 'make the label visible Me("lbl_" & D).Caption = D & "/" & M 'give the label, a caption Full_Cells = Full_Cells + 1 rpt_width = rpt_width + Me("txt_" & D).Width 'add the width 'Debug.Print "ON " & Me("txt_" & D).Name & vbTab & "D:" & D & vbTab & "Full:" & Full_Date & vbTab & "A:" & A End If Next D Me.Width = rpt_width + Me("mogh_name").Width 'the final Report width End Sub جعفر 1030.rpt_Monthly_Crosstaby.mdb

انظر الى هذا الملف لتعرف كيف يكون جدول اكسل في الصفحة الاولى الجدول خطأ في الصفحة الثانية كيف تكون بنية الجدول الصحيح قبل الجدول وبعده / الى يمينه أو يساره / ادمج ما طاب لك من الخلايا How excel Know table.xlsx

اهلا بك اخى الكريم بالمنتدى يمكنك مشاهدة هذا https://www.officena.net/ib/topic/49980-اضخم-كتاب-لتعلم-الصيغ-والدوال-في-excel-2007/?tab=comments#comment-305377 https://academy.hsoub.com/apps/productivity/office/microsoft-excel/أساسيات-الجداول-المحورية-pivot-tables-في-microsoft-excel-r78/ https://www.youtube.com/watch?v=4ek9Nx7NabI https://www.youtube.com/watch?v=8YKyWmgYQkw وهذا ايضا ملف للشرح http://www.mediafire.com/file/vq7w66awnex69b2/pivot+tables.rar

أخي الكريم أبو يوسف لم يتم الرد للآن وتأكيد الطلب (ورغم أنني من أنصار عدم تقديم المساعدة إلا إذا توافر الشرح الكافي للطلب بالتفصيل ولكن ما باليد حيلة) سأقوم بطرح ما قام به أخونا الحبيب مختار عن طريق الأكواد بعيداً عن معادلات الصفيف .. الآن تم دمج الطلبات بشكل مبدئي ..الجزء الأول تحدد الملفات المراد تجميعها ثم يتم تجميعها كل ملف أو مصنف في ورقة عمل ، ثم الجزء الثاني يتم استخراج مكاتب التربية الغير مكررة في العمود M وفي العمود المقابل له عدد هذه المكاتب ... إذا كان للطلب بقية فأفضل أن يكون في كود منفصل .. حتى لا نتوه بين أسطر الأكواد .. إليك الكود بالشكل النهائي له Sub CollectDataFromMultipleWorkbooks() Dim OpenFiles Dim crntfile As Workbook Set crntfile = Application.ActiveWorkbook Dim X As Integer Dim SH As Worksheet Dim Arr, Temp, I As Long, J As Long, P As Long Dim Rng As Range, ColFound Dim Data As Variant Dim Obj As Object On Error GoTo ErrHandler Application.ScreenUpdating = False OpenFiles = Application.GetOpenFilename(FileFilter:="Microsoft Excel Files (*.csv;*.xlsx;.xlsm),*.csv;*.xlsx;*.xlsm", MultiSelect:=True, Title:="Select Excel File To Merge!") If TypeName(OpenFiles) = "Boolean" Then MsgBox "You Need To Select At Least One File" GoTo ExitHandler End If X = 1 While X <= UBound(OpenFiles) Workbooks.Open Filename:=OpenFiles(X) Sheets().Move After:=crntfile.Sheets(crntfile.Sheets.Count) X = X + 1 Wend For Each SH In ThisWorkbook.Sheets With SH If .Name <> "Master" Then Arr = .Range("A1").CurrentRegion.Value For I = 1 To UBound(Arr) Temp = Split(Arr(I, 1), ";") For J = 1 To UBound(Temp) .Cells(I, J) = Temp(J) Next J Next I .Range("A1").CurrentRegion.Columns.EntireColumn.AutoFit ColFound = Application.Match("*مكتب التربية*", .Rows(1), 0) If IsNumeric(ColFound) Then With .Columns("M:N") .ClearContents .Borders.LineStyle = xlNone .Interior.Color = xlNone End With .Range("M2:N2") = Array("مكتب التربية", "العدد") Set Rng = .Range(.Cells(2, ColFound), .Cells(.Cells(Rows.Count, ColFound).End(xlUp).Row, ColFound)) Set Obj = CreateObject("scripting.dictionary") Data = Rng For P = 1 To UBound(Data) Obj(Data(P, 1) & "") = "" Next .Range("M3:M1000").ClearContents .Range("M3").Resize(Obj.Count, 1) = Application.Transpose(Obj.keys) With .Range("N3:N" & .Cells(Rows.Count, "M").End(xlUp).Row) .Formula = "=COUNTIF(" & Rng.Address & ",M3)" .Value = .Value End With With .Range("M2").CurrentRegion .Range("A1:B1").Interior.Color = vbYellow .Borders.Weight = xlThin .BorderAround Weight:=xlThick .Columns.AutoFit End With End If End If End With Next SH ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub تقبل تحياتي Collect Data From Multiple CSV Workbooks Mokhtar V2.rar

بعد جزيل الشكر لكل من ساهم في هذا الموضوع من الأساتذة اسمحوا لي بإضافة بسيطة يعلمها الكثير منا وهي طريقة يعتمدها الإكسل في إدراج التاريخ الحالي والوقت الحالي في خلية بدون أكواد أو ماكرو لإدراج التاريخ الحالي نضغط CTRL+; الضغط على زر كنترول + حرف الكاف باللغة العربية لإدراج الوقت الحالي نضغط CTRL+SHIFT+; الضغط على زر كنترول+زر الشيفت + حرف الكاف باللغة العربية دمتم سالمين