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

جرب المعادلة التالية =AVERAGEIFS(H4:H33,H4:H33,">=14",H4:H33,"<=26")

جرب الكود التالي .. في ورقة العمل 2 ضع التاريخ المطلوب في الخلية G4 ثم نفذ الكود Sub Test() Dim ws As Worksheet Dim sh As Worksheet Dim fd As Range Set ws = Sheets("Sheet1") Set sh = Sheets("Sheet2") Application.ScreenUpdating = False Set fd = ws.Rows(5).Find(sh.Range("G4").Value) If Not fd Is Nothing Then ws.Range(ws.Cells(7, fd.Column), ws.Cells(302, fd.Column + 4)).Copy sh.Range("F6") Application.CutCopyMode = False End If Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله وبركاته بارك الله فيك أخي العزيز زيزو العجوز .. حل آخر إثراءً للموضوع ... الأخ السائل : أولاً ستقوم بتغيير أسماء الأشكال الموجودة في ورقة العمل لديك لأن الأسماء الطويلة للأشكال ستسبب لك أخطاء في الخطوات التالية ، ويمكن تغيير أسماء الأشكال الموجودة في ورقة العمل بهذا الكود Sub RenameAllShapes() Dim i As Long For i = 1 To Sheet1.Shapes.Count Sheet1.Shapes(i).Name = "Shape" & i Next i End Sub الخطوة الثانية هي تعيين ماكرو لكل الأشكال مرة واحدة بدلاً من تعيين ماكرو لكل شكل على حدا باستخدام الماكرو التالي Sub AssignMacroToAllShapes() Dim shp As Shape For Each shp In ActiveSheet.Shapes shp.OnAction = "IncrementMe" Next shp End Sub الماكرو الأخير والأساسي هو الماكرو التالي والذي سينفذ بمجرد الضغط على أي شكل من الأشكال الموجودة لديك في ورقة العمل Sub IncrementMe() Dim lRow As Long Dim lCol As Long Application.ScreenUpdating = False With Sheet1.Shapes(Application.Caller) lCol = .TopLeftCell.Column lRow = .TopLeftCell.Row Cells(lRow, lCol).Offset(, 1).Value = Cells(lRow, lCol).Offset(, 1).Value + 1 End With Application.ScreenUpdating = True End Sub ** ملحوظة قبل تنفيذ أي خطوة انسخ كل الأكواد في موديول قبل البدء في عملية التنفيذ .. بعد النسخ قم بتنفيذ الخطوة الأولى والثانية مرة واحدة فقط ... أما الخطوة الثالثة ستكون مرتبطة بالأشكال الموجودة في ورقة العمل تقبل تحياتي

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

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

ممكن توضبح أكثر للمطلوب .. ما هي ورقة العمل المطلوب عليها وأين تصميم الورقة المطلوب العمل عليها؟

بسم الله ما شاء الله أخي الغالي أبو يوسف ملف رائع وله رونق خاص ومميز تقبل وافر تقديري واحترامي

غير في الإعدادات ..اتبع الخطوات في الصورة

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

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

وعليكم السلام بدون تجربة الكود واعتماداً على الكود الذي أرفقته أخي الكريم .. تم التعديل بالشكل التالي (وضعت تعليق على السطر الجديد) Sub HidUnused() Dim rng As Range Dim cell As Range Dim x As Variant Set rng = Range("A10:A30") 'تم إضافة متغير وتعيين قيمة له ثم يستخدم المتغير في الكود x = Range("A1").Value 'Or x=405 For Each cell In rng If cell.Value <> x Then cell.EntireRow.Hidden = True ElseIf cell.Value = x Then cell.EntireRow.Hidden = False End If Next cell End Sub

جربي المعادلة التالية =IFERROR(INDEX($B$2:$B$4,MATCH(F2,$A$2:$A$4,0)),"")

السلام عليكم جرب الكود التالي Sub FillUsingArrays() Dim arr(1 To 50000, 1 To 5) Dim i As Long Dim j As Long Dim iRow As Long Application.ScreenUpdating = False arr(1, 1) = "السنة": arr(1, 2) = "الشهر" arr(1, 4) = "السنة": arr(1, 5) = "الشهر" iRow = 2 For i = 4000 To 1 Step -1 For j = 1 To 12 arr(iRow, 1) = i & " ق م" arr(iRow, 2) = Choose(j, "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", "يوليه", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") iRow = iRow + 1 Next j Next i iRow = 2 For i = 1 To 2020 For j = 1 To 12 arr(iRow, 4) = i & " ب م" arr(iRow, 5) = Choose(j, "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", "يوليه", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") iRow = iRow + 1 Next j Next i Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr Application.ScreenUpdating = True End Sub

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

جرب المصنف باسم آخر من خلال الخيار Save As وأعطه اسم مختلف في مكان آخر وجرب فتح الملف الجديد والعمل عليه والحفظ ..

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

شاهد الفيديو التالي

وعليكم السلام أخي الكريم ممكن تتواصل معي على الفيس وأحاول أن أعطيك بعض التعديلات للتجربة ، لأنني لا أعمل على الـ 64 بت في الوقت الحالي حسابي على الفيس هو yakh777@yahoo.com

شاهد الفيديو على الرابط التالي

وعليكم السلام جرب الكود التالي .. Sub Test() Dim i As Long Application.ScreenUpdating = False For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row RemoveDuplicatesInCell Range("B" & i), Range("C" & i), "،" Next i Application.ScreenUpdating = True End Sub Sub RemoveDuplicatesInCell(rng As Range, rngT As Range, Optional delim As Variant) Dim d As Object Dim arr() As String Dim i As Long If IsMissing(delim) Then delim = ", " Set d = CreateObject("Scripting.Dictionary") arr = Split(rng, delim) For i = LBound(arr) To UBound(arr) d(arr(i)) = 1 Next i rngT.Value = Join(d.keys, " ، ") d.RemoveAll End Sub

بالفعل .. مشكلة حيث لا تظهر الردود إلا حين ترد فقط وفي وقتها أما بعد ذلك تختفي

بارك الله فيكم إخواني الكرام وجزيت خيرا الجزاء

السلام عليكم أخي الكريم قصي .. ادخل لرابط الموضوع وتأكد من التالي

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

شاهد الفيديو التالي لتتعرف كيفية تفعيل الماكرو ..