عبدالله بشير عبدالله قام بنشر يونيو 1 قام بنشر يونيو 1 السلام عليكم ورحمة الله وبركاته عذرا لتأخرى في الرد حسب الصورة المرفقة مع ردكم الكريم اظافة عنصر فارغ في القائمة e5 وبناء عليه تكون b10&g10 فارغتان تم التعديل و يمكنك تعديل نطاق القائمة كما تشاء يمكنك الاسنغناء عن زر انقر هنا للبحث وإذا لاحظت أي شيء يحتاج تعديل أو عندك أي فكرة تحب نضيفها، أنا حاضر بأي وقت، لك كل الود والتقدير طريقة اخرى للبحث معدلة6.xlsb 1
algammal قام بنشر يونيو 3 الكاتب قام بنشر يونيو 3 أخي الكريم الفاضل الأستاذ / @محمد هشام. السلام عليكم ورحمة الله وبركاته كل عام وأنتم جميعا بخير وصحة وسعادة بمناسبة اقتراب عيد الأضحى المبارك أعاده الله عليكم وعلينا وعلى الأمة الإسلامية جميعا بالخير واليمن والبركات والعام القادم بأمر الله نكون سويا على جبل عرفات اللهم آمين رب العالمين. وكل عام وجميع أوفيسنا (Excel) الكرام جميعا بخير في 31/5/2025 at 22:07, محمد هشام. said: ربما ما لم تلاحظه هو أن القيم تعبأ على عناصر الكومبوبوكس مع تجاهل الفراغات والتكرارات ولهذا السبب تظهر معك مرة واحدة فقط وذلك لأن أرقام التسلسل الموجودة على ورقة معاشات هي نفسها الموجودة على الـ DATA ما يهمنا هنا هو جلب جميع البيانات المتوفرة على الورقتين التي تتضمن شروط التصفية المختارة بداية أحييكم وأشكر لكم روعة وتفصيل الرد ما أروع وما أجمل ما صنعت يداكم حفظكم الله ورعاكم؛ وسلمتم وسلمت يداكم على هذا الجمال وهذه الروعة؛ وعلى كل ما قدمتموه؛ فلقد صار البدر قمرا منيرا؛ ووصل لمرحلة التمام والكمال؛ فجزاكم الله خير الجزاء؛ وفي ميزان حسناتكم بأمر الله. وكل عام وأنتم بخير؛ ودامت دياركم عامرة بكل ما يحبه الله ويرضاه.
algammal قام بنشر يونيو 3 الكاتب قام بنشر يونيو 3 أخي الكريم الفاضل الأستاذ / @عبدالله بشير عبدالله السلام عليكم ورحمة الله وبركاته كل عام وأنتم جميعا بخير وصحة وسعادة بمناسبة اقتراب عيد الأضحى المبارك أعاده الله عليكم وعلينا وعلى الأمة الإسلامية جميعا بالخير واليمن والبركات والعام القادم بأمر الله نكون سويا على جبل عرفات اللهم آمين رب العالمين. وكل عام وجميع أوفيسنا (Excel) الكرام جميعا بخير في 1/6/2025 at 23:38, عبدالله بشير عبدالله said: عذرا لتأخرى في الرد ليس عليكم اعتذار؛ وإنما الاعتذار واجب منا لكم على تعبكم معنا؛ فتقبلوا اعتذارنا مغلفا بكامل الشكر والاحترام والتقدير لشخصكم الكريم في 1/6/2025 at 23:38, عبدالله بشير عبدالله said: وإذا لاحظت أي شيء يحتاج تعديل أو عندك أي فكرة تحب نضيفها، أنا حاضر بأي وقت، هذا ما عهدناه عليكم أدامكم الله عزا وعونا لنا؛ وهذا ما يشجعنا ويجعلنا نسألكم دوما بدون تردد مرة تلو الأخرى وكلنا ثقة ويقين في تقديم الإجابات والحلول الناجحة الشافية لكل ما نسأل عنه في 1/6/2025 at 23:38, عبدالله بشير عبدالله said: لك كل الود والتقدير ولكم منا كل ود واحترام وتقدير وشكر بلا حدود ما أروع وما أجمل ما صنعت يداكم حفظكم الله ورعاكم؛ وسلمتم وسلمت يداكم على هذا الجمال وهذه الروعة؛ وعلى كل ما قدمتموه؛ فلقد صار البدر قمرا منيرا؛ ووصل لمرحلة الكمال؛ فجزاكم الله خير الجزاء؛ وفي ميزان حسناتكم بأمر الله. مجرد تساؤل فقط: هل من الممكن أن يكون هناك ارتباط بين الخلية الفارغة في (E5) وزر (أنقر هنا لمسح البيانات) بحيث يقوم الزر بنفس وظيفة الخلية الفارغة بأبسط طريقة ممكنة؟ مع بيان شرح مبسط لذلك إن وجد. وكل عام وأنتم بخير؛ ودامت دياركم عامرة بكل ما يحبه الله ويرضاه.
عبدالله بشير عبدالله قام بنشر يونيو 3 قام بنشر يونيو 3 (معدل) وعليكم السلام ورحمة الله وبركاته 4 طرق لمسح البيانات 1- زر به كود مسخ البيانات (جديد) يقوم الزر بنفس وظيفة الخلية الفارغة 2- اخنيار الخلية الفارغة من E5 (بعد عمل زر المسخ ليس لها ضرورة ) 3- الخروج من شيت SEARCH ثم العودة اليه 4- النقر مرتين في اي خلية في شيت SEARCH وايسرها كما تفضلتم زر المسح او النقر مرنين كما انوه ان تحديث البيانات اظافة وظيفة جديدة ..... الخ الى شيت DATA او معاشات يتم تلقائيا مع الانتباه لزيادة مدى البيانات للقائمة من التحقق من صحة البيانات انمنى اتى قدمت ما بقيد وما زال الباب مفتوحا لمفترحاتكم او ملاحظاتكم وكل عام وانتم بالف خير طريقة اخرى للبحث معدلة7.xlsb تم تعديل يونيو 3 بواسطه عبدالله بشير عبدالله 1
محمد هشام. قام بنشر يونيو 3 قام بنشر يونيو 3 1 ساعه مضت, algammal said: بداية أحييكم وأشكر لكم روعة وتفصيل الرد ما أروع وما أجمل ما صنعت يداكم حفظكم الله ورعاكم؛ وسلمتم وسلمت يداكم على هذا الجمال وهذه الروعة؛ وعلى كل ما قدمتموه؛ فلقد صار البدر قمرا منيرا؛ ووصل لمرحلة التمام والكمال؛ فجزاكم الله خير الجزاء؛ وفي ميزان حسناتكم بأمر الله. وكل عام وأنتم بخير؛ ودامت دياركم عامرة بكل ما يحبه الله ويرضاه. العفو أخي الكريم @algammal سعدنا دائما بمشاركتنا في إثراء الموضوع وتقديم الاقتراحات التي تساعدك على تحقيق النتائج المطلوبة والشكر الكبير للأستاذ الفاضل عبد الله على جهوده القيمة ومساهمته المتميزة بعد مراجعة الملف المقدم من أستاذنا الفاضل @عبدالله بشير عبدالله لاحظنا أنك تعتمد على معيار واحد فقط لجلب البيانات وليس عدة معايير كما ظننا في البداية لو عرفنا هذا منذ البداية لكان بإمكاننا تقديم حلول أبسط مما تم تطبيقه ضمن اليوزرفورم حيث كنا نعتقد أنك تحتاج بحثا ديناميكيا بعدة معايير مع ذلك لديك الآن عدة طرق مختلفة وجميعها فعالة ويمكنك اعتماد الأنسب منها حسب طبيعة عملك واحتياجاته 1
algammal قام بنشر يونيو 4 الكاتب قام بنشر يونيو 4 أخي الكريم الأستاذ / @عبدالله بشير عبدالله السلام عليكم ورحمة الله وبركاته كل عام وأنتم بخير وصحة وسعادة 14 ساعات مضت, عبدالله بشير عبدالله said: انمنى اتى قدمت ما بقيد لقد كفيت ووفيت؛ جعلكم الله من سعداء الدنيا والآخرة؛ ووضع لكم القبول في الأرض والسماء؛ وجزاكم الله خيرا. وعيد أضحى مبارك أخي الكريم الأستاذ / @محمد هشام. السلام عليكم ورحمة الله وبركاته كل عام وأنتم بخير وصحة وسعادة 13 ساعات مضت, محمد هشام. said: بعد مراجعة الملف المقدم من أستاذنا الفاضل @عبدالله بشير عبدالله لاحظنا أنك تعتمد على معيار واحد فقط لجلب البيانات وليس عدة معايير كما ظننا في البداية لو عرفنا هذا منذ البداية لكان بإمكاننا تقديم حلول أبسط مما تم تطبيقه ضمن اليوزرفورم حيث كنا نعتقد أنك تحتاج بحثا ديناميكيا بعدة معايير بالفعل أخي الكريم كنت أحتاج بحثا ديناميكيا بعدة معايير. لقد كفيت ووفيت؛ جعلكم الله من سعداء الدنيا والآخرة؛ ووضع لكم القبول في الأرض والسماء؛ وجزاكم الله خيرا. وعيد أضحى مبارك أخي الكريم الأستاذ الفاضل / @عبدالله بشير عبدالله أخي الكريم الأستاذ الفاضل / @محمد هشام. ما قدمتموه لي كالعين اليمنى واليسرى لا يستطيع الإنسان الاستغناء عن أي منهما أو كلاهما لإبصار تام؛ فكلاهما في منتهى الغلاوة؛وأبشركما أن كلا من الملفين لن أستغني عن أحدهما؛ وبأمر الله تعالى سيتم العمل بهما معا فكل منهما له استخدامه. وجزاكم الله خير الجزاء؛ ولن أنساكم من دعاء يوم عرفة فضلا وعرفانا بجميلكم دمتم عونا لكل من أراد العون ومثلا يحتذى لكل من أراد القدوة
algammal قام بنشر يونيو 4 الكاتب قام بنشر يونيو 4 أخي الكريم الأستاذ الفاضل / @محمد هشام. السلام عليكم ورحمة الله وبركاته ظهرت لي هذه المشكلة عندما قمت في آخر تحديث من قبلكم باختزال الوظائف لثلاث وظائف فقط هي (محامي؛ عامل؛ طبيب) الغريب في الأمر أنها لا تظهر إلا عن اختيار وظيفة: محامي أو عامل فقط؛ في حين عند اختيار وظيفة طبيب تظهر النتائج كاملة؛ حاولت الوصول لحل ولم أعرف. فرجاء مساعدتي في الحل وجزاكم الله خيرا
عبدالله بشير عبدالله قام بنشر يونيو 5 قام بنشر يونيو 5 (معدل) السلام عليكم ورحمة الله وبركاته بعد ملاحظة ااستاذنا الفاضل محمد هشام. جزاه الله خيرا والتي ذكر فيها بعد مراجعة الملف المقدم من أستاذنا الفاضل @عبدالله بشير عبدالله لاحظنا أنك تعتمد على معيار واحد فقط لجلب البيانات وليس عدة معايير كما ظننا في البداية لو عرفنا هذا منذ البداية لكان بإمكاننا تقديم حلول أبسط مما تم تطبيقه ضمن اليوزرفورم حيث كنا نعتقد أنك تحتاج بحثا ديناميكيا بعدة معايير وتعليقكم 16 ساعات مضت, algammal said: بالفعل أخي الكريم كنت أحتاج بحثا ديناميكيا بعدة معايير. وكما اشار معلمنا الفاضل في 4/6/2025 at 00:43, محمد هشام. said: مع ذلك لديك الآن عدة طرق مختلفة وجميعها فعالة ويمكنك اعتماد الأنسب منها حسب طبيعة عملك واحتياجاته اليك الملف يبحث بعدة معايير لكما كل الود والتقدير والاحترام طريقة اخرى للبحث بعدة معايير.xlsb تم تعديل يونيو 5 بواسطه عبدالله بشير عبدالله 1
محمد هشام. قام بنشر يونيو 5 قام بنشر يونيو 5 11 ساعات مضت, algammal said: الغريب في الأمر أنها لا تظهر إلا عن اختيار وظيفة: محامي أو عامل فقط؛ في حين عند اختيار وظيفة طبيب تظهر النتائج كاملة المرجوا إرفاق الملف الذي يتضمن نفس البيانات والوظائف المذكورة للوقوف وراء سبب ظهور رسالة الخطأ معك 1
algammal قام بنشر يونيو 5 الكاتب قام بنشر يونيو 5 (معدل) 15 ساعات مضت, عبدالله بشير عبدالله said: اليك الملف يبحث بعدة معايير أخي الحبيب الأستاذ / @عبدالله بشير عبدالله السلام عليكم ورحم الله وبركاته عيد أضحى مبارك أعاده الله عليكم أعواما عديدة وأزمنة مديدة؛ وأنتم بخير وصحة وسعادة ما أجمل أن تدعو لأخيك بظهر الغيب؛ فما بالك إن كان الدعاء يوم عرفة؛ دعوت اليوم لكم بالاسم؛ حفظكم الله ورعاكم؛ وجزاكم الله خيرا. أخي الحبيب الأستاذ / @محمد هشام. السلام عليكم ورحم الله وبركاته عيد أضحى مبارك أعاده الله عليكم أعواما عديدة وأزمنة مديدة؛ وأنتم بخير وصحة وسعادة ما أجمل أن تدعو لأخيك بظهر الغيب؛ فما بالك إن كان الدعاء يوم عرفة؛ دعوت اليوم لكم بالاسم؛ حفظكم الله ورعاكم؛ وجزاكم الله خيرا. 9 ساعات مضت, محمد هشام. said: المرجوا إرفاق الملف الذي يتضمن نفس البيانات والوظائف المذكورة للوقوف وراء سبب ظهور رسالة الخطأ معك إليك الملف أخي الحبيب توحيد البحث في شيت واحد v6.xlsb تم تعديل يونيو 5 بواسطه algammal
algammal قام بنشر يونيو 5 الكاتب قام بنشر يونيو 5 أخي الحبيب الأستاذ / @عبدالله بشير عبدالله أخي الحبيب الأستاذ / @محمد هشام.
محمد هشام. قام بنشر يونيو 5 قام بنشر يونيو 5 أعتقد ان إستبدال هدا السطر سيوفي بالغرض من If xtbl > 0 Then Sh1.Range("A5").Resize(xtbl, 13).Value = Application.Index(v, Evaluate("ROW(1:" & xtbl & ")"), Evaluate("COLUMN(1:13)")) End If إلى If xtbl > 0 Then If xtbl = 1 Then Sh1.Range("A5").Resize(1, 13).Value = v Else Sh1.Range("A5").Resize(xtbl, 13).Value = v End If End If بطريقة مختلفة وأسرع نوعا ما Private Sub CommandButton1_Click() Dim i&, r&, c&, k&, t&, f&, xtbl&, lastRow&, n As Boolean, ok As Boolean, val$ Dim s, data, a(), ky(), tb(), j(), criteria() SetApp False ReDim ky(1 To MaxCombo): ReDim tb(1 To MaxCombo): ReDim j(1 To MaxCombo) For i = 1 To MaxCombo val = Trim(LCase(Me("ComboBox" & i).Value)) If val <> "" And val <> "*" Then ky(i) = val: n = True Else ky(i) = "" Next If Not n Then MsgBox "الرجاء تحديد معايير البحث", vbExclamation: GoTo CleanUp For i = 1 To MaxCombo If ky(i) <> "" Then f = f + 1: tb(f) = ColArr(i - 1): j(f) = ky(i) Next With Sh1 lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row If lastRow >= 5 Then .Range("A5:M" & lastRow).ClearContents End With data = OnRng: k = UBound(data, 1): t = 13 ReDim a(1 To k, 1 To t), criteria(1 To f) For r = 1 To k ok = True For i = 1 To f s = data(r, tb(i)) criteria(i) = IIf(IsDate(s), Format$(s, "yyyy/mm/dd"), LCase(Trim(CStr(s)))) If criteria(i) <> j(i) Then ok = False: Exit For Next If ok Then xtbl = xtbl + 1 For c = 1 To t: a(xtbl, c) = data(r, c): Next If IsDate(a(xtbl, 9)) Then a(xtbl, 8) = xDayName(Format(a(xtbl, 9), "dddd")) If IsDate(a(xtbl, 12)) Then a(xtbl, 11) = xDayName(Format(a(xtbl, 12), "dddd")) End If Next If xtbl > 0 Then Sh1.Range("A5").Resize(xtbl, t).Value = a AddBorders Sh1.Name CleanUp: SetApp True End Sub توحيد البحث في شيت واحد v7.xlsb 1
algammal قام بنشر يونيو 6 الكاتب قام بنشر يونيو 6 أخي الحبيب الأستاذ الفاضل / @محمد هشام. السلام عليكم ورحمة الله وبركاته شكرا لكم وجزاكم الله خيرا ممكن أعرف كيفية عمل الصورة المتحركة في هذا التعليق ()
محمد هشام. قام بنشر يونيو 6 قام بنشر يونيو 6 بخصوص استفساركم الكريم عن كيفية عمل الصورة المتحركة التي أرفقتها بالتعليق فالأمر ببساطة كالتالي قمت بتسجيل شاشة الجهاز باستخدام برنامج لتصوير الشاشة ثم قمت بحفظ الفيديو مباشرة بصيغة GIF وفي حالة استخدام برنامج لا يدعم هذه الصيغة يمكنك تسجيل الشاشة بصيغة فيديو عادية ثم تحويله لاحقا باستخدام أحد المواقع المجانية المتوفرة على الإنترنت بكل سهولة 1
محمد هشام. قام بنشر السبت at 16:38 قام بنشر السبت at 16:38 إليك أخي @algammal نسخة محدثة بعد تجربة الملف وظهور خطأ عند البحث بالرقم القومي لوحده توحيد البحث في شيت واحد v8.xlsb 1
algammal قام بنشر الأحد at 14:53 الكاتب قام بنشر الأحد at 14:53 أخي الفاضل الأستاذ / @محمد هشام. السلام عليكم ورحمة الله وبركاته 22 ساعات مضت, محمد هشام. said: إليك أخي @algammal نسخة محدثة بعد تجربة الملف وظهور خطأ عند البحث بالرقم القومي لوحده أشكر لك اخي الحبيب حرصك الشديد؛ ومتابعتك الدؤوبة للوصول بالعمل إلى أكمل وجه؛ والتنبيه لذلك؛ ونشر نسخة محدثة من الملف؛ فجزاكم الله خير الجزاء؛ وجعله في ميزان حسناتكم؛ مرة أخرى لكم كل الشكر والتقدير والاحترام.
algammal قام بنشر بالامس في 02:11 الكاتب قام بنشر بالامس في 02:11 (معدل) أخي الفاضل الأستاذ / @عبدالله بشير عبدالله السلام عليكم ورحمة الله وبركاته لقد قمت: 1) بتلوين علامة التبويب كما هو موضح بالشيت المرفق 2) بعمل ارتباط تشعبي (Hyperlink) للتنقل بين أوراق العمل المختلفة كما هو موضح أيضا بالشيت المرفق ولكن لاحظت بعد الضغط على زر (ترحيل البيانات) في شيت (معاشات) أولا: - يختفي لون علامات التبويب فقط في الأوراق التي تم ترحيل البيانات لها وهي كما يلي: · (طبيب – مهندس – مفتش – ضابط – محامي – عامل) في شيت (طريقة أخرى للبحث معدلة7) ثانيا: - يختفي الـ (Hyperlink) أيضا من نفس الصفحات فقط والمذكورة أعلاه. والسؤال: ما العمل لتلافي ذلك؟ مع توضيح الحل. وتقبلوا خالص أمنياتي ودعواتي لكما بأن يديم الله عليكم الصحة وموفور العافية؛ وجزاكم الله عنا خير الجزاء؛ دمتم في حفظ الله ورعايته. طريقة اخرى للبحث معدلة7.xlsb أخي الفاضل الأستاذ / @محمد هشام. السلام عليكم ورحمة الله وبركاته لقد قمت: 1) بتلوين علامة التبويب كما هو موضح بالشيت المرفق 2) بعمل ارتباط تشعبي (Hyperlink) للتنقل بين أوراق العمل المختلفة كما هو موضح أيضا بالشيت المرفق ولكن لاحظت بعد الضغط على زر (ترحيل البيانات) في شيت (معاشات) أولا: - يختفي لون علامات التبويب فقط في الأوراق التي تم ترحيل البيانات لها وهي كما يلي: · (طبيب – محامي – عامل) في شيت (توحيد البحث في شيت واحد v8) ثانيا: - يختفي الـ (Hyperlink) أيضا من نفس الصفحات فقط والمذكورة أعلاه. والسؤال: ما العمل لتلافي ذلك؟ مع توضيح الحل. وتقبلوا خالص أمنياتي ودعواتي لكما بأن يديم الله عليكم الصحة وموفور العافية؛ وجزاكم الله عنا خير الجزاء؛ دمتم في حفظ الله ورعايته. توحيد البحث في شيت واحد v8.xlsb تم تعديل بالامس في 02:16 بواسطه algammal
محمد هشام. قام بنشر منذ 14 ساعات قام بنشر منذ 14 ساعات (معدل) وعليكم السلام ورحمة الله وبركاته كان من الأفضل أخي @algammal فتح موضوع جديد لطلبك المتعلق بتعديل كود ترحيل البيانات أو على الأقل إدراج إستفسارك داخل الموضوع الأصلي المخصص لذلك وذلك أن الموضوع لم يغلق بعد ونحرص دوما على تجنب تداخل المواضيع حتى لا يحدث إرتباك أو لخبطة للقارئ لاحقا على العموم نترك هذا التقدير الكريم لإدارة المنتدى والمشرفين 23 ساعات مضت, algammal said: والسؤال: ما العمل لتلافي ذلك؟ مع توضيح الحل بالنسبة لملاحظتك حول إختفاء ألوان علامات التبويب والروابط التشعبية (Hyperlinks) بعد الضغط على زر ترحيل البيانات فالأمر ناتج ببساطة عن أن الكود يقوم بحذف الأوراق الموجودة مسبقا التي تم ترحيل البيانات لها ثم يعيد إنشاء أوراق جديدة بنفس الأسماء وبما أن الورقة تحذف تماما يتم معها حذف جميع التنسيقات والروابط التشعبية لأنها كانت مرتبطة بالورقة المحذوفة وليست بالاسم فقط نظرا للتغييرات الجديدة على الملف يمكنا تفادي هذه المشكلة بتعديل بسيط على الكود من خلال: بعد إنشاء كل ورقة جديدة بناء على إسم الوظيفة إعادة تلوين التبويب باستخدام شرط Select Case يمكنك طبعا إضافة مهن جديدة وتخصيص ألوانها بنفس الطريقة For Each f In dest.Keys Set tmp = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) tmp.Name = f: tmp.DisplayRightToLeft = True Select Case tmp.Name Case "طبيب": tmp.Tab.Color = RGB(128, 0, 128) Case "محامي": tmp.Tab.Color = RGB(101, 67, 33) Case "عامل": tmp.Tab.Color = RGB(255, 105, 180) ' يمكنك إضافة المزيد ' Case "مهندس": tmp.Tab.Color = RGB(...) End Select وكذلك نسخ الأشكال من ورقة معاشات للإحتفاظ بالإرتباط التشعبي مما يضمن إستمرار وظيفة التنقل بين الأوراق Dim Groupe As String: Groupe = "مجموعة 2" On Error Resume Next CrWS.Shapes(Groupe).Copy On Error GoTo 0 tmp.Range("C2").Select: tmp.Paste If tmp.Shapes.Count > 0 Then Set j = tmp.Shapes(tmp.Shapes.Count) CrWS.Range(harder).Copy: tmp.Range("A3").PasteSpecial xlPasteAll ليصبح الكود النهائي كما يلي : Sub TransferData() Const début As Long = 5, Height As Double = 20.25 Const départ As String = "A", Fin As String = "M" Const harder As String = "A3:M4" Dim Groupe As String: Groupe = "مجموعة 2" Dim CrWS As Worksheet, tmp As Worksheet, dest As Object Dim OnRng As Variant, i As Long, lastRow As Long, k As Variant, j As Shape Dim tbl As String, f As Variant, irow As Long, a() As Variant, n As Long, lr As Long On Error GoTo OnError Set CrWS = Sheets("معاشات"): Set dest = CreateObject("Scripting.Dictionary") lastRow = CrWS.Cells(CrWS.Rows.Count, départ).End(xlUp).Row If lastRow < début Then: MsgBox "لا توجد بيانات لترحيلها", vbExclamation: Exit Sub SetApp False OnRng = CrWS.Range(départ & début & ":" & Fin & lastRow).Value For i = 1 To UBound(OnRng, 1) tbl = Replace(Replace(Trim(OnRng(i, 5)), "/", "_"), "\", "_") If Len(tbl) > 0 Then dest(tbl) = Empty Next i For Each tmp In ThisWorkbook.Worksheets If Not tmp Is CrWS Then If dest.Exists(tmp.Name) Then On Error Resume Next: tmp.Delete: On Error GoTo OnError Next tmp For Each f In dest.Keys Set tmp = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) tmp.Name = f: tmp.DisplayRightToLeft = True Select Case tmp.Name Case "طبيب": tmp.Tab.Color = RGB(128, 0, 128) Case "محامي": tmp.Tab.Color = RGB(101, 67, 33) Case "عامل": tmp.Tab.Color = RGB(255, 105, 180) End Select On Error Resume Next CrWS.Shapes(Groupe).Copy On Error GoTo 0 tmp.Range("C2").Select: tmp.Paste If tmp.Shapes.Count > 0 Then Set j = tmp.Shapes(tmp.Shapes.Count) CrWS.Range(harder).Copy: tmp.Range("A3").PasteSpecial xlPasteAll Application.CutCopyMode = False ReDim a(1 To UBound(OnRng, 1), 1 To UBound(OnRng, 2)) n = 0 For irow = 1 To UBound(OnRng, 1) If Trim(OnRng(irow, 5)) = f Then n = n + 1 For i = 1 To UBound(OnRng, 2): a(n, i) = OnRng(irow, i) Next i End If Next irow If n > 0 Then tmp.Range("A5").Resize(n, UBound(OnRng, 2)).Value = a CrWS.Range("A5:M" & n + 4).Copy tmp.Range("A5").PasteSpecial xlPasteFormats Application.CutCopyMode = False End If CrWS.Columns("A:M").Copy tmp.Columns("A:M").PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False lr = tmp.Cells(tmp.Rows.Count, départ).End(xlUp).Row For i = 1 To lr: tmp.Rows(i).RowHeight = Height: Next i tmp.Rows(2).RowHeight = 24 k = Array("=COUNTIF($M$5:$M$" & lr & ", $B$3)", "=COUNTIF($F$5:$F$" & lr & ", $D$3)", _ "=COUNTIF($F$5:$F$" & lr & ", $G$3)") tmp.[C3].Formula = k(0): tmp.[E3].Formula = k(1): tmp.[H3].Formula = k(2) tmp.Range("A5:A" & lr).Formula = "=IF(B5<>"""",SUBTOTAL(3,$B$5:B5),"""")" tmp.[A4].Select Next f CrWS.Activate CleanUp: SetApp True MsgBox "تم ترحيل البيانات بنجاح", vbInformation Exit Sub OnError: Resume CleanUp End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub النتائج المتوقعة : توحيد البحث في شيت واحد v9.xlsb تم تعديل منذ 2 ساعات بواسطه محمد هشام. 1
محمد هشام. قام بنشر منذ 12 ساعات قام بنشر منذ 12 ساعات (معدل) أخي @algammal بما أننا اعتمدنا على العمل الديناميكي أثناء التعامل مع الملف أود أن أشاركك طريقة أخرى أكثر ديناميكية لإنشاء الأزرار الخاصة بالتنقل بين الأوراق دون الحاجة إلى نسخ الارتباطات من ورقة معاشات يتم إنشاء زر لكل ورقة عمل في المصنف بشكل تلقائي - استثناء الورقة التي يشير إليها الزر أي لا يضاف زر داخل نفس الورقة - تلوين الزر بنفس لون تبويب الورقة التي يشير إليها الزر لسهولة التعرف والتمييز البصري ربط الزر بكود التنقل GotoSheet الموضح أدناه مما يتيح الانتقال بين أوراق العمل المقصودة دون الإعتماد على أي إرتباط تشعبي Sub GotoSheet() SetApp False Dim wsName As String wsName = Replace(Application.Caller, "btn_", "") On Error Resume Next ThisWorkbook.Sheets(wsName).Activate On Error GoTo 0 SetApp True End Sub توحيد البحث في شيت واحد v10.xlsb تم تعديل منذ 2 ساعات بواسطه محمد هشام.
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.