ياسر خليل أبو البراء

لقد كررت عليك الفكرة في ثلاثة مشاركات مختلفة .. الحمد لله أن انتهيت من المشكلة الأولى التي لم تكن مشكلة في الأساس !!!!! غير الخاصية المسماة PasswordChar الخاصة بـ TextBox2 ضع بها القيمة * لتظهر لك كلمة السر على شكل نجوم ..............

لا يوجد مشكلة والكود يعمل معي بشكل طبيعي والاختصار يعمل بشكل طبيعي ..أما المشكلة فهي لديك .. وللأسف نحن لسنا جالسون على جهازك لمعرفة المشكلة بالضبط من المفترض أن تنقل لنا الصورة بشكل صحيح ليتسنى للأخوة مساعدتك ذكرت أنه لا توجد رسائل خطأ .. إذاً لا مشكلة في الكود أخبرنا ما الذي يحدث معك عندما تضغط على ctrl + q لتنفيذ الكود ؟؟ وتأكد أن اتجاه لوحة المفاتيح للكتابة باللغة الإنجليزية عند تنفيذ الاختصار تقبل تحياتي

إذا كنت تقصد أن يكون الناتج بالموجب قم باستخدام الدالة ABS لتحويل السالب إلى موجب بالنسبة للتنسيق قم بتحديد الخلايا التي بها الناتج ثم اختر التنسيق الشرطي واختر New Rule ثم اختر Format only cells that contain ثم ابدأ في التعامل مع المخرجات .. يعني الصفر مثلاً اختر من القائمة Cell value ثم اختر من القائمة التالية equal أي تساوي ثم ضع الرقم صفر وانقر على تنسيق Format واختر اللون المناسب لك كرر نفس الخطوات مع تغيير القائمة الثانية إلى greater than أو less than حسب الرغبة ..

هل جربت ان يكون اتجاه الكتابة باللغة الإنجليزية قبل الضغط على Ctrl + q ؟؟؟

أي شاشة تقصد ؟؟ أي من الفورم تقوم بحذفه فيعمل معك الكود ؟؟ واعذرني لأنني لم أتابع من البداية ولا أدري ما هو الكود المرتبط بـ Ctrl + Q ..ألقي نظرة سريعة على عمل الكود حتى يتسنى الوصول لحل للمشكلة بشكل سريع تأكد أن اتجاه الكتابة باللغة الإنجليزية ليعمل معك الكود بالاختصار Ctrl + q حيث أنه مرتبط بالكود Call_All ولكن لن يعمل إلا إذا كان اتجاه الكتابة باللغة الإنجليزية

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

أخي الكريم ما هي الخلايا المراد جمعها أعتقد أن المرفق غير مطابق للمطلوب هل المطلوب فقط تنسيق شرطي لتلوين النتائج في العمودين E و H ...؟ أم ماذا الرجاء إلقاء مزيد من الضوء حول طلبك ......

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

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

أخي الحبيب زيزو أضحك الله سنك ..كيف يقلب الورقة ؟؟! خايف بدل ما يقلب الورقة يقلب دماغة عشان يشوف الطباعة بالعكس

أخي الكريم أحمد ولا محمد فؤاد الحمد لله أن تم المطلوب على خير .. هذا بفضل الله ثم بفضل الله أن يسر لك شخصاً يقوم بذلك الأمر فاحمد الله أولاً وأخيراً بالنسبة لطلبك الثاني غريب شوية ومش منطقي ..هتفرق ايه الطباعة من الآخر للأول أو من الأول للآخر .مجرد تساؤل عموماً جرب التعديل في هذا السطر ..قم باستبدال السطر التالي For I = (LBound(Arr) + 1) To UBound(Arr) بهذا السطر For I = UBound(Arr) To (LBound(Arr) + 1) Step -1

أخي الكريم أبو يوسف ممكن ترفق شكل المخرجات بالنسبة للورقة التجميعية واسم الورقة ... وأفضل عمل كود منفصل يقوم بالمهمة ..لأن الكود أصبح في توهاااااااان وحتى تتضح الصورة أمامكم ..أو يمكن عمل كود منفصل ثم استدعاء الكود عن طريق الأمر Call .. أخي الحبيب مختار قوم بما تبقى من المهمة حيث أنني مشغول قليلاً ..بارك الله فيك وجزيت خيراً على كلماتك الطيبة وإعجابك بالمشاركة الأخيرة لي ..اللي صاحب الموضوع نفسه تجاهلها ...!

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

'In Standard Module '----------------- #If VBA7 Then Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long Private Declare PtrSafe Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hwnd As LongPtr) As Long #Else Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" ( ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" ( ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function DrawMenuBar Lib "User32" ( ByVal hwnd As Long) As Long #End If Sub RemoveCaption(objForm As Object) Dim lStyle As Long Dim hMenu As Long Dim mhWndForm As Long If Val(Application.Version) < 9 Then mhWndForm = FindWindow("ThunderXFrame", objForm.Caption) Else mhWndForm = FindWindow("ThunderDFrame", objForm.Caption) End If lStyle = GetWindowLong(mhWndForm, -16) lStyle = lStyle And Not &HC00000 SetWindowLong mhWndForm, -16, lStyle DrawMenuBar mhWndForm End Sub Sub ShowForm() UserForm1.Show False End Sub 'In UserForm Module '------------------ Private Sub UserForm_Initialize() Call RemoveCaption(Me) End Sub تفضل أخي الكريم

لا غلط .. هي في الأصل 100 فل و 14 (إنت هتكروتنا في التحليل بتاعك)

تمام يا أبو العربي كدا 99 فل و12 ..

أخي الكريم أحمد جرب المعادلة التالية في الخلية E2 =IF(D2>=2110,316.5,ROUND(D2*15%,2)) إذا صادفتك مشكلة قم باستبدال الفاصلة الموجودة في المعادلة بفاصلة منقوطة تقبل تحياتي

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

شوف الفورم الموجود اللي اسمه elmalak واعمل عليه كليك يمين ثم View Code ستجد الأسطر في بداية الكود الخاص بالفورم ..

أخي الغالي ياسر فتحي بارك الله فيك على الموضوع الجميل أخي الكريم عبد العزيز نظراً لأنك تستخدم اللغة الفرنسية فيمكنك استخدام الدالة CAR المقابلة للدالة CHAR تقبلوا تحياتي

أخي الكريم ارفق الملف للإطلاع عليه .. هل كان يعمل الملف قبل إضافة معينة قد تكون السبب في المشكلة؟

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

إذا واجهتك مشكلة أخي الكريم أبو راكان فاطرح المشكلة التعامل مع نظام 64 بت يحتاج لممارسة ولا يوجد قواعد ثابتة بشكل كبير ..أنا أجتهد في التعديل إلى أن يتم الأمر (لأنني بدأت التعامل مع 64 بت منذ فترة) تقبل تحياتي

أخي الكريم أبو يوسف لم يتم الرد للآن وتأكيد الطلب (ورغم أنني من أنصار عدم تقديم المساعدة إلا إذا توافر الشرح الكافي للطلب بالتفصيل ولكن ما باليد حيلة) سأقوم بطرح ما قام به أخونا الحبيب مختار عن طريق الأكواد بعيداً عن معادلات الصفيف .. الآن تم دمج الطلبات بشكل مبدئي ..الجزء الأول تحدد الملفات المراد تجميعها ثم يتم تجميعها كل ملف أو مصنف في ورقة عمل ، ثم الجزء الثاني يتم استخراج مكاتب التربية الغير مكررة في العمود 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

أخي الحبيب مختار يمكن استخدام الدالة Match لمعرفة رقم العمود الخاص بمكتب التربية دون اللجوء إلى الحلقات التكرارية التي من شأنها أن تبطيء عمل الأكواد بشكل ملحوظ Sub CountIf() Dim SH As Worksheet Dim ColFound Application.ScreenUpdating = False For Each SH In ThisWorkbook.Sheets If SH.Name <> "Master" Then ColFound = Application.Match("*مكتب التربية*", SH.Rows(1), 0) If IsNumeric(ColFound) Then MsgBox ColFound End If Next SH Application.ScreenUpdating = True End Sub