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

أخي الكريم مرجان موضوعك بسيط جداً قبل كلمة ActiveCell والتي تتعامل مع الخلية النشطة أو المحددة تكتب أو تشير لاسم ورقة العمل وهناك أكثر من طريقة لعمل ذلك إما أن تكتب كلمة Sheets يليها قوس مفتوح ثم قوس تنصيص ثم اسم ورقة العمل (حسب الاسم الذي كتبته لورقة العمل Data مثلا) ثم تغلق أقواس التنصيص ثم قوس مقفول يتبعها نقطة ثم كلمة ActiveCell أو يمكنك استخدام الاسم البرمجي بشكل مباشر .. اذهب لمحرر الأكواد وانظر في نافذة المشروع على الاسم البرمجي كما بالصورة التالية الاسم البرمجي Sheet1 أي يمكنك التعديل بنفسك ليكون بهذا الشكل أو هذا الشكل (وأنا أفضل التعامل مع الاسم البرمجي) Sheets("Data").ActiveCell 'OR Sheet1.ActiveCell تقبل تحياتي

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

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

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

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

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

أخي الكريم جرب الملف المرفق فيه الحل بالتنسيق الشرطي المكرر.rar

أخي الكريم رضا لما لا تضع الكود داخل ملف إكسيل ليكون الشرح أيسر ..؟

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

أنا أبدي ملاحظاتي فقط أخي الحبيب عماد ، وليس للنقد والله بالعكس سعدت جداً بشرحك الرائع والدليل أنني شاهدت الفيديو بالكامل وبالأمارة كمان (هنقول بسم الله الرحمن الرحيم 4 مرات)

أخي الغالي عماد في الجزئية الخاصة بتلوين النطاق استخدمت كلمة Cells ومن الممكن عدم استخدامها أقصد أنه يمكن استخدام السطر بهذا الشكل Range("A1:C1").Interior.ColorIndex = 3 متابعك ..! ومراقبك ..!

بارك الله فيك وجزاك الله كل خير أخي الحبيب عماد هنقول بسم الله الرحمن الرحيم تقبل الله منكم صالح الأعمال

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

عندما وضعت رد في مشاركتي السابقة انتظرتك لأكثر من نصف ساعة ولم ترد فنسيت إرفاق الملف ..عموماً لعله خير وهذا هو الحل ..رغم إني أعتقد أنه لا حاجة لك به طالما أن الأمر قد انتهى وتم Sub Split_Multi_Lines() Dim a, I As Long, II As Long, X, Rng As Range Dim myRows As Long, N As Long, Txt As String Application.ScreenUpdating = False With Sheets("Sheet1").[B2].CurrentRegion Set Rng = .Offset(.Rows.Count + 3).Cells(1) Rng.CurrentRegion.Clear .Copy Rng End With With Rng.CurrentRegion a = .Value Txt = Join(Application.Transpose(.Columns(1).Value), vbLf) myRows = Len(Txt) - Len(Replace(Txt, vbLf, "")): N = 2 .Rows(2).Copy .Rows(3).Resize(myRows - 1) For I = 2 To UBound(a, 1) For II = 1 To UBound(a, 2) If a(I, II) <> "" Then X = Split(a(I, II), vbLf) .Cells(N, II).Resize(UBound(X) + 1).Value = Application.Transpose(X) End If Next N = N + UBound(Split(a(I, 1), vbLf)) + 1 Next I .Rows.AutoFit End With Application.ScreenUpdating = True End Sub تقبل تحياتي

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

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

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

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

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

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

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

وعليكم السلام ورحمة الله وبركاته وجزيت خيراً بمثل ما دعوت لي أخي العزيز محمد عبد السلام

أخي الكريم جرب الكود التالي .. Sub Test() Const lngStartRow As Long = 2 Dim strFile As String Dim strFileName As String Dim lngMyRow As Long Dim lngLastRow As Long Dim lngMatchRow As Long Dim rngDelete As Range strFile = Sheet1.Range("A4").Value & ".xlsx" strFileName = ThisWorkbook.Path & "\" & strFile Application.ScreenUpdating = False If Len(Dir(strFileName)) > 0 Then Workbooks.OpenText Filename:=strFileName lngLastRow = ActiveWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row For lngMyRow = lngStartRow To lngLastRow lngMatchRow = 0 On Error Resume Next lngMatchRow = Evaluate("MATCH([" & strFile & "]Sheet1!A" & lngMyRow & ",[" & ThisWorkbook.Name & "]Sheet1!B:B,0)") If lngMatchRow > 0 Then If rngDelete Is Nothing Then Set rngDelete = ActiveWorkbook.Sheets("Sheet1").Cells(lngMyRow, "A") Else Set rngDelete = Union(rngDelete, ActiveWorkbook.Sheets("Sheet1").Cells(lngMyRow, "A")) End If End If On Error GoTo 0 Next lngMyRow If Not rngDelete Is Nothing Then If Evaluate("Sum([" & strFile & "]Sheet1!" & rngDelete.Offset(, 2).Address & ")") = ThisWorkbook.Sheets("Sheet1").Range("C5").Value Then rngDelete.EntireRow.Delete MsgBox "تم حذف الصفوف من مصنف العميل", 64 ActiveWorkbook.Close True Else MsgBox "الفواتير متطابقة ولكن مجموع الفواتير غير متطابق", 64 ActiveWorkbook.Close False End If Else MsgBox "لا يوجد أرقام فواتير متطابقة", vbExclamation ActiveWorkbook.Close False Exit Sub End If Else MsgBox strFileName & " الملف غير موجود!", vbExclamation, "File Not Found" End If Application.ScreenUpdating = True End Sub أرجو أن يكون المطلوب ويفي بالغرض إن شاء الله

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

وما يدريك أن العمل يحتاج لدقائق ..؟؟ وما يدريك أن الـ 33 زيارة لمجرد الزيارة لابد وأن أحدهم يريد المساعدة ولكن ليس لديه العلم الكافي لتقديم الحل أو لربما يكون التوضيح للمسألة غير دقيق أو لربما يكون الملف غير واضح أو لربما لأسباب أخرى الرجاء التماس العذر لإخوانك .. وألتمس منك التوضيح بأسلوب آخر ولو بالصور أو بإرفاق النتائج المتوقعة ساعتها ستجد أحد الأعضاء الـ 33 سيقدم المساعدة ..