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

بارك الله فيكم إخواني الأحباب إليكم معادلة الصفيف التالية لعلها تضاف إلى بقية المعادلات .. نريد التركيز في الموضوع على الحصول على آخر قيمة سواء أكانت القيمة نصية أو رقمية =OFFSET($B$2,MAX(IF(NOT(ISBLANK($B$3:$B$22)),ROW($B$3:$B$22),0))-ROW($B$2),0) وننتظر ملف آخر من الأخ الحبيب محمد الريفي يجمع بقية المعادلات المقدمة من كل الأخوة الكرام

أخي الكريم جرب المعادلة التالية =ADDRESS(MATCH(A6,ورقة1!$A$1:$A$6,0),1,2) أو جرب نفس معادلة الباشمهندس طارق =MID(CELL("address",OFFSET(ورقة1!$A$1,MATCH(A6,ورقة1!$A$2:$A$5,0),0)),FIND("!",CELL("address",OFFSET(ورقة1!$A$1,MATCH(A6,ورقة1!$A$2:$A$5,0),0)))+1,LEN(CELL("address",OFFSET(ورقة1!$A$1,MATCH(A6,ورقة1!$A$2:$A$5,0),0))))

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

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

بارك الله فيك وجزاك الله خيراً أخي الغالي زوهير إن شاء الله ننتظر المزيد من إبداعاتك

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

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

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

جرب الكود بهذا الشكل Sub YasserKhalil() Dim I As Long On Error Resume Next For I = 6 To Cells(Rows.Count, 2).End(xlUp).Row + 1 If IsEmpty(Cells(I, 2)) Then Cells(I, 2).Resize(1, 22).Interior.Color = RGB(192, 192, 192) Cells(I, 2).Resize(1, 22).Formula = "=SUM(R[-" & ii & "]C:R[-1]C)" End If Next I End Sub عله يفي بالغرض

أخي الحبيب سليم مجرد ملاحظة .. عند كتابة أسماء جديدة لا تتم إضافتها في القائمة المنسدلة في الحال .. لابد لاضافتها من إغلاق الملف ثم فتحه مرة أخرى (حاجة غريبة ...) وحتى جربت مجرد الحفظ لا يتم تحديث القائمة المنسدلة .. تفتكر ايه السبب ؟! بحاول الاقي المشكلة فين ؟! بصيت على Calculation Options لاقيت Automatic

أي ملف يمكنك تطبيق الفكرة بسهولة عن طريق تصدير الفورم Export ومن الملف المراد العمل عليه اعمل Import

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

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

أخي الكريم محمد أهلاً ومرحباً بك في المنتدى بين إخوانك يرجى تغيير اسم الظهور للغة العربية جرب المعادلة التالية .. ويرجى فيما بعد إرفاق الملف نفسه وليس صورة للعمل عليه ، ولمزيد من كيفية التعامل مع المنتدى يرجى زيارة رابط التوجيهات في الموضوعات المثبتة في صدر المنتدى =TRIM(MID(A1,FIND("-",A1)+1,LEN(A1))) تقبل الله منا ومنكم صالح الأعمال

الحمد لله أن تم المطلوب على خير متنسناش بدعوة على السحور

جرب السطر بهذا الشكل ExportToTextFile FName:="C:\Test.txt" , Sep:=";", SelectionOnly:=True, AppendData:=True

حدد المسار بالضبط وأنا سأقوم بالتعديل أو قم بالتعديل وحاول غير السطر ThisWorkbook.Path إلى المسار الذي تريده C:\Test.txt

أخي الفاضل من المفترض أن ترفق ملف به الكود المراد التعديل عليه حتى تسهل على إخوانك .. عموماً .... حصل خير إليك الكود التالي عله يفي بالغرض Sub ExtractTwoNames() Dim Rng As Range, Cell As Range Dim lRow As Long Dim AWF Set Rng = Range("B2:B" & Cells(Rows.Count, 1).End(3).Row) Set AWF = Application.WorksheetFunction lRow = 2 Application.ScreenUpdating = False For Each Cell In Rng If kh_Names(AWF.Trim(Cell.Value), 1) = AWF.Trim(Cell.Value) Or kh_Names(AWF.Trim(Cell.Value), 1, 2) = AWF.Trim(Cell.Value) Then Cells(lRow, 4) = Cell.Offset(, -1): Cells(lRow, 5) = Trim(Cell): lRow = lRow + 1 Next Cell Application.ScreenUpdating = True End Sub Function kh_Names(FullName As String, ParamArray iNdex1()) As String Dim I As Integer Dim kh_Split, MyArray, Ar Dim Kh_String As String, Sn As String, Re As String On Error GoTo Err_Kh_Names MyArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله", " الدين", " الإسلام", " الاسلام", " الحق", " النصر", " العهد", " النور", " بالله") Sn = Application.WorksheetFunction.Trim(FullName) For Each Ar In MyArray Re = Replace(Ar, " ", "^") Sn = Replace(Sn, Ar, Re) Next kh_Split = Split(Sn, " ", , vbTextCompare) On Error Resume Next For I = 0 To UBound(iNdex1) Kh_String = Kh_String & " " & kh_Split(iNdex1(I) - 1) Next On Error GoTo 0 Kh_String = Replace(Trim(Kh_String), "^", " ") kh_Names = Kh_String Exit Function Err_Kh_Names: kh_Names = "" End Function تقبل تحياتي Extract Single & Double Names V2 YasserKhalil.rar

أخي الكريم لم أفهم المطلوب الثاني ؟ ماذا تقصد بتحديد مكان النسخة ؟

قبل أن تطلب الشرح .. هل جربت الكود أخي الفاضل وأدى الغرض أم لا؟ هكذا يجب أن يكون الرد !

أخي الفاضل تعليموه إليك الكود مع شرح بسيط لأسطر الكود لعله يفي بالغرض ويفيدك في التعديل Sub YasserKhalil() 'تعريف المتغيرات Dim Rng As Range, DN As Range, nRng As Range, Temp As Range, R As Range Dim SHT As Worksheet Dim SHP As Shape 'إلغاء خاصية رسائل التنبيه Application.DisplayAlerts = False 'سطر لتجنب احتمال حدوث خطأ On Error Resume Next 'حذف ورقة العمل المسماة النتيجة المطلوبة في حالة وجودها Sheets("النتيجة المطلوبة").Delete 'نسخ ورقة العمل المسماة المشكلة في آخر أوراق العمل Sheets("المشكلة").Copy After:=Sheets(Sheets.Count) 'تعيين المتغير ليساوي ورقة العمل النشطة Set SHT = ActiveSheet 'تسمية ورقة العمل التي تم نسخها باسم النتيجة المطلوبة SHT.Name = "النتيجة المطلوبة" 'بدء التعامل مع ورقة العمل المسماة النتيجة المطلوبة With Sheets("النتيجة المطلوبة") 'وحتى آخر صف به بيانات في العمود [A1] تعيين المتغير ليساوي النطاق الذي يبدأ من الخلية Set Rng = .Range("A1").Resize(.Range("A1").CurrentRegion.Rows.Count) 'حلقة تكرارية لحذف الأشكال مثل الأسهم For Each SHP In .Shapes SHP.Delete Next SHP 'حلقة تكرارية لكل خلية في النطاق الذي تم تعييه في العمود الأول For Each DN In Rng 'إذا لم تكن الخلية في العمود الأول فارغة يتم تنفيذ السطر التالي If Not IsEmpty(DN.Value) Then 'ليساوي قيمة الخلية في العمود الثالث [Temp] يتم تعيين المتغير 'لاحظ رقم الإزاحة 2 أي الانتقال والإزاحة عمودين بعد العمود الأول Set Temp = DN.Offset(, 2) 'أما في حالة أن الخلية كانت فارغة يتم تنفيذ الأسطر التالية Else 'يساوي قيمة الخلية في العمود الثالث إذا كان المتغير فارغ ليس به قيمة بعد [Temp] المتغير 'أما إذا لم يكن المتغير فارغ فإنه يساوي القيمة الموجودة بالفعل مضافاً إليها علامة الشرطة ثم القيمة الجديدة Temp = IIf(IsEmpty(Temp), DN.Offset(, 2).Value, Temp & " - " & DN.Offset(, 2).Value) 'يساوي شيئاً يتم تنفيذ السطر التالي [nRng] إذا لم يكن المتغير المسمى If nRng Is Nothing Then 'تعيين المتغير ليساوي عنوان الخلية الحالية أو النطاق الحالي Set nRng = DN 'وإلا Else 'يتم تعيين المتغير ليساوي النطاق المخزن في المتغير مع نطاق الخلية الحالية Set nRng = Union(nRng, DN) End If End If Next DN '[nRng] حذف الصفوف التي تكون الخلية في العمود الأول فيها فارغة والتي تم تخزيناه في النطاق المسمى If Not nRng Is Nothing Then nRng.EntireRow.Delete 'بدء التعامل مع النطاق الحالي With .Range("A1").CurrentRegion 'رسم حدود خارجية للنطاق باللون الأسود والخط الرفيع .BorderAround ColorIndex:=1, Weight:=xlThin 'التوسيط الأفقي للبيانات .HorizontalAlignment = xlCenter 'التوسيط الرأسي للبيانات .VerticalAlignment = xlCenter End With End With 'إعادة تفعيل خاصية رسائل التنبيه Application.DisplayAlerts = True End Sub لا تنسانا بدعوة على الإفطار (مش دلوقتي .. ساعة الإفطار) تقبل الله منا ومنكم

جرب المعادلة بهذا الشكل علها تؤدي الغرض إن شاء المولى =IFERROR(IF(B85="","",SUMPRODUCT(($D$8:$D$80=B85)*(INDIRECT(ADDRESS(8,MATCH($D$84,$G$7:$AK$7,0)+6)&":"&ADDRESS(80,MATCH($D$84,$G$7:$AK$7,0)+6))>=5)*(INDIRECT(ADDRESS(8,MATCH($D$84,$G$7:$AK$7,0)+6)&":"&ADDRESS(80,MATCH($D$84,$G$7:$AK$7,0)+6))<=14))),"") تقبل تحياتي

أخي الكريم سليم جرب الكود بهذا الشكل Sub DoIt() Dim Cell As Range For Each Cell In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) Cell.Offset(, 1) = "=" & Cell.Value Next Cell End Sub إن شاء الله تظبط معاك تقبل تحياتي

جربي الكود التالي عله يفي بالغرض إن شاء المولى Sub HideZeroColumns() Dim Cell As Range For Each Cell In Range("C17:X17") If IsEmpty(Cell) Or Cell = 0 Then Cell.EntireColumn.Hidden = True Next Cell End Sub كل عام وأنتي بخير

أختي الفاضلة ما هو النطاق المراد العمل عليه ؟ هل هو C17:X17 فقط .. ؟ مزيد من التوضيح حيث ان التوضيح المرفق في المرفق غير مطابق للمرفق