الخالدي

السلام عليكم ورحمة الله وبركاته
التنسيق المطلوب يمكن تطبيقه في اكسل 2007 و2010
تنسيق شرطي2007.rar

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

السلام عليكم ورحمة الله
ايضا من الفرق
الدالة vlookup تبحث في الصفوف
الدالة Match تبحث في الصفوف او الاعمدة
وفرق اخر
الدالة vlookup تبحث قيمة واحدة
الدالة Match تبحث عن قيمة واحدة او مجموعة من القيم -هنا لا  تستخدم مع Index  كمرجع للصف
وفرق اخر
الدالة vlookup تُرجع النتيجة  كـ قيمة
اما Match و Index  تُرجع النتيجة  كـ مرجع   لذلك يمكن استخدام النتيجة لدوال تتطلب مرجعا فمثلا لو استخدمناها وسيطا للدالة ROW نحصل على رقم صف الخلية
في امان الله

السلام عليكم ورحمة الله
جرب المرفق
ديوان شعر11.rar

السلام عليكم ورحمة الله
الكود التالي يضيف ارتباط تشعبي في العمود D ورقة الطلب الاول
ضع الكود في حدث تغير الورقة
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row > 1 And Target.Column = 1 Then For Each C In Intersect(Target, [A2:A10000]) Pth = ActiveWorkbook.Path & "\" & C & ".pdf" C(1, 4).Hyperlinks.Delete If C = "" Then     C(1, 4) = "" Else     If Dir(Pth) <> "" Then         C(1, 4).Hyperlinks.Add C(1, 4), Pth, , , "فتح الملف"     Else         C(1, 4) = "الملف غير متوفر"     End If End If Next End If End Sub ارجو ان يكون المطلوب
في امان الله

السلام عليكم ورحمة الله
جزاك الله خيرا واحسن اليك ولك مثل دعائك لي  اخي الكريم
جرب التعديل التالي للكود
Sub AL_KHALEDI() With Sheets("بيانات") Set Rng = Range(.Cells(3, 1), .Cells(Rows.Count, 1).End(xlUp)(1, 49)) End With Col = Application.Match([A1], Rng.Rows(0), 0) + 1 ReDim Arr(1 To 3, 1 To 3) For r = 1 To Rng.Rows.Count If Rng(r, Col) <> "" And Rng(r, 2) = [A3] Then If Application.CountIfs( _       Rng(1, 2).Resize(r), Rng(r, 2), _       Rng(1, 5).Resize(r), Rng(r, 5), _       Rng(1, 6).Resize(r), Rng(r, 6), _       Rng(1, Col).Resize(r), Rng(r, Col)) = 1 Then W = Application.Match(Rng(r, 5), [{"الخط الأول","الخط الثاني","الخط الثالث"}], 0) H = Application.Match(Rng(r, 6), [{"الوردية الصباحية","الوردية المسائية","الوردية الليلية"}], 0) If Not IsError(W) And Not IsError(H) Then Arr(W, H) = Arr(W, H) & Rng(r, Col).Value & Chr(10) End If: End If: End If Next r For Each C In [M8:O8,M18:O18,M28:O28] C.Value = "" L = Len(Arr(A Mod 3 + 1, Int(A / 3) + 1)) If L Then C.Value = Mid(Arr(A Mod 3 + 1, Int(A / 3) + 1), 1, L - 1) A = A + 1 Next C Set Rng = Nothing: Erase Arr MsgBox "تم بحمد الله" End Sub

السلام عليكم ورحمة الله
اضافة الى رأي الاستاذ الفاضل/ شوقي ربيع حفظة الله
قم باضافة  كلمة PtrSafe بعد كلمة Declare
واذا ترغب بان يعمل الكود على 64 او32 بت استخدم الدالة #If على الشكل التالي
#If VBA7 Then Declare PtrSafe ... #Else Declare ... #End If في احيان اخرى قدم يلزم تعديل نوع المتغير
في امان الله

السلام عليكم ورحمة الله
ضع المعادلة التالية في الخلية F152 ثم اسحبها لبقية الخلايا
=IF(COUNTIF(D$11:D152;D152)>1;LOOKUP(2; 1/((D$11:D152=D152)*(ROW(E$11:E152)<ROW())); E$11:E152);"لا يوجد") ارجو ان يكون المطلوب

السلام عليكم ورحمة الله
المرفق بالكود
في امان الله
عد خلايا بالكود.rar

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

السلام عليكم ورحمة الله وبركاته
الاخ الحبيب الشهابي
اعتقد ان السبب في السطر التالي من الكود
If C = 0 Then End فاذا تحقق شرط الدالة If في السطر السابق فيتم انهاء الكود بدون تنفيذ الاوامر في الاسطر اللاحقة من الكود بما فيها امر تفعيل الحساب التلقائي
جرب تعديل السطر السابق بحيث عند تحقق الشرط ينتقل الكود الى قبل السطر الخاص بتفعيل الحساب التلقائي وليس انهاء تنفيذ الكود
والله اعلم
في امان الله

السلام عليكم ورحمة الله وبركاته
جرب الكود التالي
Sub Farz2() For Each S In Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5")) With Range(S.Cells(2, 1), S.Cells(S.Rows.Count, 1).End(xlUp)(1, 18))     .Sort .Cells(3), 1, .Cells(4), , 1     .Sort .Cells(1), 1, .Cells(2), , 1 End With Next End Sub في امان الله
ترتيب2.rar

السلام عليكم ورحمة الله وبركاته
حسب فهمي للمطلوب
جرب الكود التالي
Sub AL_KHALEDI() For Each C In Intersect([R2:Z10000], ActiveSheet.UsedRange) If C = "" Then If C.MergeArea.Cells(1).Address = C.Address Then If C.Column = C.MergeArea.Cells(1, 1).Offset(-1, 0).MergeArea.Cells(1, 1).Column Then C.Value = C.MergeArea.Cells(1, 1).Offset(-1, 0).MergeArea.Cells(1, 1).Value End If End If End If Next End Sub في امان الله
تعبئة الخلايا الفارغة.rar

لم افهم المطلوب جيدا
في الملف المرفق يتم استدعاء الشركات التي  في المدى من "h2 الي  h38 " مع تكرار الشركات التي تحتوي على نفس الاسم لكن لا يتم ترتيب الشركات حسب الاسم.
بالنسبة للمدى في الملف 2nd يمكنك زيادته من ادارة الاسماء
واعتذر مقدما ان كان لك طلب اخرى حيث سأكون مشغولا  لكن ستجد كل التعاون من اخوة المنتدى
في أمان الله
استدعاء من ملف اكسل اخر بشرط2.rar

السلام عليكم
إنشاء pivot table نطاقات الدمج المتعددة.rar
http://office.microsoft.com/client/helppreview.aspx?AssetId=HA102265859990&lcid=1025&NS=EXCEL&Version=12&CTT=5&origin=HP010095249
المطلوب غير واضح

في أمان الله


 

السلام عليكم ورحمة الله وبركاته
بارك الله فيك اخي احمد عبد الناصر
ما شاء الله اكوادك سهلة وممتازة
ولإثراء الموضوع
الكود المرفق يعمل عند مسح خلية او اكثر في النطاق C5:K22
في أمان الله
ترحيل الخلايا الممسوحة غير الفارغة.rar

الفاضل / دغيدى
جرب الكود التالي

Sub AL_KHALEDI() Rows.EntireRow.Hidden = False Rows([J2]).Resize([K2] - [J2] + 1).EntireRow.Hidden = True End Sub واذا تعني بان الصفوف تبدأ من بداية الجدول (الصف رقم 4) جرب الكود التالي Sub AL_KHALEDI() Rows.EntireRow.Hidden = False Rows([J2]).Offset(3, 0).Resize([K2] - [J2] + 1).EntireRow.Hidden = True End Sub
اتمنى ان يكون المطلوب