أ / محمد صالح

جرب هذا الكود المختصر بإذن الله يكون هو المطلوب Private Sub CommandButton1_Click() Dim contact As String, mytext As String contact = TextBox1.Value mytext = TextBox2.Value ' Google Messages ActiveWorkbook.FollowHyperlink Address:="https://messages.google.com/web/conversations/new" Application.Wait (Now + TimeValue("00:00:10")) Call SendKeys(contact, True) Application.Wait (Now + TimeValue("00:00:04")) Call SendKeys("{TAB}", True) Application.Wait (Now + TimeValue("00:00:01")) Call SendKeys("~", True) ' Enter key Application.Wait (Now + TimeValue("00:00:04")) Call SendKeys(mytext, True) Application.Wait (Now + TimeValue("00:00:01")) Call SendKeys("~", True) ' Enter key Application.Wait (Now + TimeValue("00:00:04")) MsgBox "Done by mr-mas.com" End Sub بالتوفيق

إذا كان مقصودك اختيار المجلد الفرعي من العشرة لمرة واحدة فلماذا لا يتم تمرير اسم المجلد الفرعي للكود ؟؟ مثلا المجلد الفرعي رقم 1 يتم نسخ جميع الملفات في المجلد الفرعي رقم 1 داخل المجلد الذي يوافق اسم الملف. وفي هذه الحالة ما فائدة المجلدات الفرعية التسعة الأخرى؟؟؟!!! على العموم ضع متغيرا جديدا للمجلد الفرعي في آخر الإعلان عن المتغيرات Dim extension As String Dim subfolder as String واستبدل هذه السطور قبل النسخ If fileName = folderName Then FileCopy sourcePath & fileItem, targetPath & folderItem & "\" & fileItem End If إلى هذه والتي تعرض مستعرض المجلدات لمرة واحدة في أول ملف ابتداء من أول مجلد ثم يتم النسخ في المجلد الفرعي بنفس الاسم في جميع المجلدات المطابقة لاسماء الملفات If fileName = folderName Then If subfolder = "" then With Application.FileDialog(msoFileDialogFolderPicker) .Title = "اختيار المجلد الفرعي" .InitialFileName = targetPath & folderItem & "\" If .Show = -1 Then subfolder = .SelectedItems(1) & "\" Else MsgBox "لم يتم اختيار المجلد الفرعي" Exit Sub End If End With End If FileCopy sourcePath & fileItem, subfolder & fileItem End If بالتوفيق

ربما الكلام غير منطقي أو متناقض كيف يتم فتح مستعرض المجلدات لحضرتك أكثر من 1000 مرة لتختار مكان الملف في العشرة مجلدات ؟؟؟؟؟؟؟؟ وما فائدة الكود إذن؟؟؟ مجرد أن يذهب بك إلى المجلد الذي باسم الملف لتختار منه موضع النسخ يديويا؟؟؟؟؟

يمكنك استعمال هذه المعادلة لاقتصاص الأرقام من الثاني بطول 11 رقما =MID(A2,2,11) بالتوفيق

الكود يقوم بنسخ الملفات إلى مجلدات بنفس الاسم فمثلا ملف اسمه 17.pdf يتم نسخه في مجلد 17pdf على أي أساس تريد وضعه في أحد المجلدات العشرة؟ داخل المجلد 17pdf ؟؟؟

حسب فهمي للمطلوب يمكنك استعمال هذه المعادلة في الخلية V3 مع الاعتماد على خلايا الاعمود AD & AF حتى يمكن تغيير النسب بدون تغيير المعادلة =IF(V1<AD1,AF1,IF(V1<AD3,AF2,AF3))*V1-V2 بالتوفيق

لا يوجد مشكلة بالملف تم تثبيت الصفوف من 1 إلى 8 من نافذة إعداد الصفحة في تبويب pagelayout بالتوفيق التمـــام الشهــري.xlsx

إن شاء الله تفيدك معادلات البحث والاقتصاص هذه مع ضرورة ثبات قالب الرسائل على هذه الصيغة بالتوفيق رسائل كاش.xlsx

يوجد اختلاف بين العنوان ومضمون الموضوع فإذا كنت تريده عند إغلاق ورقة العمل يمكنك وضع الكود بدون أول وآخر سطر في حدث إلغاء تفعيل الشيت Private Sub Worksheet_Deactivate() End Sub ةإذا كان المفصود عند إغلاق الملق كله فيمكنك وضعه في حدث قبل إغلاق مصنف العمل thisworkbook Private Sub Workbook_BeforeClose(Cancel As Boolean) End Sub بالتوفيق

حسب فهمي للمطلوب جرب استعال هذه المعادلة =SUBTOTAL(103,A2:A1000) لعد الخلايا الظاهرة في العمود A بالتوفيق

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

أخي الكريم لماذا كل هذا التردد والحيرة؟؟؟؟!!!!!! عرضت قبل ذلك مشكلتك هـــــــــتا وحذرتك من اختلاف طريقة التعامل مع الأرقام فبعض الأرقام تضرب في 1000 وبعض الأرقام توضع كما هي وباستجوابك توصلنا إلى أنه إذا كانت الأرقام موجبة تضرب في 1000 وإذا كانت الأرقام سالبة توضع كما هي واليوم تضع اختلافا جديدا حيث تريد أن بعض الأرقام الموجبة تضرب في 1000 وبعضها لا تضرب!!!!!! فعلي أي أساس؟؟؟ وللمرة المليون يجب توحيد طريقة التعامل مع المدخلات فإذا كنت تضرب في 1000 فيجب كتابة ال 1000 بصورة 1 وفي هذه الحالة يكوزن المجموع 1+2 = 3 في 1000 = 3000 وكذلك في حالة الأرقام السالبة تريد إنقاص 500 تكتب - 0.5 عند الضرب في 1000 = -500 بهذه الطريقة ستقلل طول المعادلة وتقلل نسبة الخطأ بالتوفيق

يمكنك إضافة شكل شفاف بدون إطار وعند تحديده تكتب في شريط المعادلة =J5 ليعرض النص المختار من القائمة ويمكن تحريك هذا الشكل إذا تغير حجم الصورة بالتوفيق

ما دامت ورقة العمل محمية فلا يمكن دمج الخلايا إلا باستعمال كود VBA وأن يبدأ الكود بسطر لفك الحماية ثم أي كود تريده كدمج نطاق معين أو دمج الخلايا المحددة ثم آخر سطر لإعادة حماية الشيت مرة أخرى ActiveSheet.Unprotect "password" Range("C3:E3").Merge 'Selection.Merge ActiveSheet.Protect "password" وأنصح ألا يحتاج المستخدم لدمج خلايا جديدة بعد حماية ورقة العمل فالأولى دمج الخلايا قبل الحماية بالتوفيق

خطوة جميلة بالتوفيق

ما شاء الله إبداع وفقك الله أخي الفاضل ابو أحمد

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

تفضل جرب هذا التعديل جعل اسم مربع النص 11 وليس 12 وعمل بعض التعديلات في نوع المتغيرات التي تساعد في عملية البحث بالتوفيق متابعة8.xlsm

يبدو أن حضرتك لم تقرأ الرد السابق للأستاذ محمد حسن وخصوصا آخر حل وهو تعديل كود التفقيط ليناسب الأعداد الترتيبية جميعها وبالنسبة لعدم ظهور الرقم يمكن أن تمرر للدالة رقم الصف row() أو تنقص منه أي عدد من الصفوف ليبدأ من 1 بالتوفيق

أخي الكريم مطلوبك سهل بإذن الله لكن يوجد بعض الخطوات قبل تنفيذه وهي: إعادة حفظ الملفات باسم (ولو بنفس الاسم) حيث أنها تظهر خطأ عند فتحها ضبط مكان الارقام في العمود K حيث أنها في معظم الملفات في العمود K بعدها اصنع ملفا وضع به هذا الكود Sub GetDataFromFiles() Dim oFSO As Object, oFolder As Object, oFile As Object Dim lr As Long, iCnt As Long, iTotalRows As Long Dim src As Workbook, dst As Workbook Set dst = ActiveWorkbook Set oFSO = CreateObject("Scripting.FileSystemObject") Set oFolder = oFSO.GetFolder(ActiveWorkbook.Path) Application.ScreenUpdating = False For Each oFile In oFolder.Files If oFile.Name <> ActiveWorkbook.Name And Left(oFile.Name, 1) <> "~" Then Set src = Workbooks.Open(oFile.Path, True, True) iTotalRows = src.Worksheets(1).Cells(Rows.Count, "K").End(xlUp).Row For iCnt = 1 To iTotalRows lr = dst.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row dst.Sheets(1).Range("A" & lr + 1).Value = src.Sheets(1).Range("K" & iCnt).Value Next iCnt src.Close False End If Next oFile Set oFSO = Nothing: Set oFolder = Nothing: Set oFile = Nothing Application.ScreenUpdating = True MsgBox "Done by mr-mas.com" End Sub ثم قم بتنفيذ هذا الإجراء سيتم جلب بيانات العمود K من الملفات في العمود A في الملف الجديد الذي به الكود بالتوفيق

بارك الله لك أخي @أبومروان ويمكن اختصار هذه المعادلة إلى هذه =CHOOSE(B1,"الأول","الثاني","الثالث","الرابع","الخامس","السادس","السابع","الثامن","التاسع","العاشر","الحادي عشر","الثاني عشر","الثالث عشر","الرابع عشر","الخامس عشر","السادس عشر","السابع عشر","الثامن عشر","التاسع عشر","العشرون") بالتوفيق

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

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

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

لا أدري ما معنى كلمة (نفس المشكلة) ؟؟؟؟ الصورة المرفقة تدل على أن الاكسل قام بحذف 477 من المكررات وتبقى 1424 بعد أن كان يظهر رسالة لا يوجد مكررات وهذه صورة نتيجة تحويل الخلايا لأرقام عن طريق زر الخطأ وليس عن طريق تنسيق الخلايا ثم حذف المكررات