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

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

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

أخي السائل أعتقد أن الحلول المقدمة تفي بالغرض ولكن .. لي تعقيب بسيط : هل الأرقام المستخرجة في العمود الأول مأخوذة من برنامج آخر ؟ لأنك طلبت إزالة المسافة ؟؟ سؤال آخر : ما الهدف من الطلب ؟ أقصد ما الهدف من تجميع الخلايا التي بها الرقم 1؟ وهل المطلوب تقصد به أن تكون الخلية كلها بها الرقم 1 أو أن جزءاً منها يحتوي 1 مثل 121 ...؟

أخي الكريم أبو لجين إليك التعديل ليناسب طلبك إن شاء المولى Function AnglesAverage(Rng As Range) Application.Volatile Dim Cell As Range, Counter As Long, Temp For Each Cell In Rng If Cell.Value < 180 And Not IsEmpty(Cell) Then Temp = Temp + Cell.Value + 360 Else Temp = Temp + Cell.Value End If If Not IsEmpty(Cell) Then Counter = Counter + 1 Next Cell AnglesAverage = Temp / Counter If AnglesAverage >= 360 Then AnglesAverage = AnglesAverage - 360 End Function قم بإدراج الكود مكان الكود القديم واذهب لورقة العمل وإذا وجدت النتائج لم تتغير يرجى الضغط على Ctrl + Shift + F9 لا تنسى أن تحدد أفضل إجابة ، ولو فيها رزالة مني متنساش تضغط على "أعجبني هذا"

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

قم بالإطلاع على المرفق التالي لتتضح الفكرة لك وإذا أعجبتك الفكرة بدأنا في التنفيذ Store V1.rar

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

ربما لم أفهم المطلوب بشكل جيد قمت بعمل دالة معرفة تتعامل مع كل زاوية .. إذا كانت الزاوية أقل من 180 يتم إضافة 360 لها وهكذا ثم يتم عد الزوايا وحساب المتوسط على حسب العدد أرجو أن يكون المطلوب .. Function AnglesAverage(Rng As Range) Dim Cell As Range, Counter As Long, Temp For Each Cell In Rng If Cell.Value < 180 And Not IsEmpty(Cell) Then Temp = Temp + Cell.Value + 360 Else Temp = Temp + Cell.Value End If If Not IsEmpty(Cell) Then Counter = Counter + 1 Next Cell AnglesAverage = Temp / Counter End Function تقبل تحياتي Angles Average UDF Function.rar

أخي الكريم المرفق لا يوضح طريقة حساب الفرق بين الزوايا اضرب مثال واشرح كيف تتم عملية حساب الفرق بين الزوايا بشكل يدوي ...

أخي الكريم هل اسمك الحقيقي أبو ياسر أم أنه مجرد اسم ؟؟ عموماً تم عمل المطلوب ووضع الكود في حدث فتح المصنف فكرة الكود تعتمد على إظهار الورقة المخفية ثم تنفيذ المطلوب ثم إخفاء الورقة مرة أخرى يمكنك تجربة الكود بهذا الشكل لترى إذا كان يعمل بشكل جيد أم لا قم بإظهار الورقة المخفية وامسح العمود الثاني وأخفي الورقة واحفظ المصنف وأغلقه قم بفتح المصنف وأظهر الورقة المخفية لترى النتيجة المطلوبة لا تنسى ان تحدد أفضل إجابة ليظهر الموضوع منتهي ومجاب عليه كما لا تنسى أن تضغط "أعجبني هذا" إذا أعجبتك المشاركة تقبل تحياتي Auto Copy Sheet4 V2.rar

أخي الكريم أشرف إليك الملف التالي فيه 90% مما طلبت أما بالنسبة للتلوين لا أرى داعي لها حيث أن كل توجيه في مصنف مستقل الآن .. قمت بحذف جميع التنسيقات الموجودة في المصنفات المصدرة جرب الملف التالي وأعلمنا بالنتيجة Export Workbooks Using Filter Method.rar

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

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

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

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

أخي الكريم يرجى في موضوعات لاحقة إن شاء الله أن يكون الملف المرفق معبر عن الطلب تماماً .. حاول تراعي وقت وجهد الآخرين بالله عليك أمر آخر ...هل الملف رقم معبر عن شكل الملف الأصلي ؟؟ إذ لاحظت أنه في الصف رقم 11 أن هناك عناوين موجودة مرتين result5 و result6 (هذا غير معبر بعض الشيء) ..كما أن هناك عناوين مختلفة عن العناوين في الملف رقم 2 ... هناك عنوان result 5 يوجد مسافة بين الكلمة والرقم عموماً قمت بمسح العناوين في العمود Gو H في الملف رقم 1 كما قمت بإزالة المسافة بين الكلمة والرقم في الملف رقم 1 أيضاً ليعمل الكود بشكل جيد حيث أن الكود الآن يعتمد على عناوين الصف رقم 14 في الملف رقم 2 ، وعناوين الصف رقم 11 في الملف رقم 1 ، ليتم جلب البيانات في المكان المناسب من المكان المناسب إليك الكود التالي لعله يفي بالغرض Sub ImportData() Dim WB As Workbook, myRng As Range, Cell As Range Dim myRow As Long, lCol As Long Dim shMain As Worksheet Application.ScreenUpdating = False Set shMain = ThisWorkbook.ActiveSheet Set WB = Workbooks.Open("G:\1.xlsx") On Error Resume Next For Each Cell In shMain.Range("C14:F14") With WB.Sheets("Data") lCol = Application.WorksheetFunction.Match(Cell, .Rows(11), 0) Set myRng = WB.Sheets("Data").Range(.Cells(12, lCol), .Cells(.Cells(Rows.Count, lCol).End(xlUp).Row, lCol)) myRng.Copy shMain.Cells(15, Cell.Column).PasteSpecial xlPasteValues End With Next Cell WB.Close True Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Task Completed" End Sub ملحوظة يوضع الملف رقم 1 في المسار المكتوب في الكود في البارتشن G وإليك الملف المرفق Work.rar

أخي الكريم ارفق ملفك ليساعدك الأخوة الأعضاء

يرجى يرجى يرجى .. وضع الأكواد بين أقواس تنصيص الكود <> ، كما يرجى تغيير اسم الظهور للغة العربية -------------------- هل تقصد الورقة مخفية أم محمية ؟ الأمر يختلف .. لو كانت الورقة مخفية ...في بداية الكود تظهر ورقة العمل وفي النهاية سطر للإخفاء مرة أخرى ولكن السؤال ... الذي يجب أن نفكر فيه كيف سيتم تنفيذ الكود وتنفيذ الكود مرتبط بتنشيط ورقة العمل وورقة العمل مخفية إذاً أعتقد أنك تقصد أن الورقة محمية والكود الذي أرفقته يفي بالغرض في هذه الحالة Private Sub Worksheet_Activate() ActiveSheet.Unprotect Password:="123456" With Range("AH1", Cells(Rows.Count, "AH").End(xlUp)) Range("AM1").Resize(.Rows.Count).Value = .Value End With ActiveSheet.Protect Password:="123456" End Sub يرجى مراعاة الدقة في اللفظ لتتضح الأمور

جرب الكود بهذا الشكل لعله يكون المطلوب Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [A2:F2]) Is Nothing Then If Target = "" Then AutoFilterMode = False Else Range("RN").AutoFilter , field:=Target.Column, Criteria1:="*" & Target & "*" End If End If End Sub

الأخ الفاضل طائع جرب الكود بهذا الشكل Sub Circles1() Dim C As Range Dim MyRng As Range, V As Shape Dim X As Integer, G As Integer, R As Integer, D As Integer '================================================ G = 2 ' عمود رقم الجلوس R = 11 ' صف الدرجات Set MyRng = Range("O12:CQ132") ' نطاق الخلايا الذي تريد اضافة الدوائر فيها '================================================ X = ActiveWindow.Zoom Application.ScreenUpdating = False ActiveWindow.Zoom = 100 For Each C In MyRng If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Value = "غ" Or C.Value = "صفر") And Not IsEmpty(C.Value) Then Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 1, C.Top + 1, C.Width - 1, C.Height - 1) V.Fill.Visible = msoFalse 'لون الدائرة V.Line.ForeColor.SchemeColor = 10 'سمك خط الدائرة V.Line.Weight = 1.9 D = D + 1 End If Next ActiveWindow.Zoom = X Application.ScreenUpdating = True MsgBox "تم إضافة " & D & " دائرة بنجاح", vbMsgBoxRtlReading, "الحمدلله" End Sub Sub RemoveCircles1() Dim shp As Shape, D As Integer For Each shp In ActiveSheet.Shapes If shp.AutoShapeType = msoShapeOval Then shp.Delete: D = D + 1 Next shp MsgBox "تم حذف " & D & " دائرة بنجاح", vbMsgBoxRtlReading, "الحمدلله" End Sub

بارك الله فيك أخي الحبيب الغالي مختار زيادة في الخير وإثراءً للموضوع إليك الحل التالي ..حيث يتم إنشاء مصنف لكل توجيه ويستثنى "بدون توجيه" ، كما يستثنى "بدون توجيه" في مصنف "قوائم التوجهات الكلية" يتم إنشاء مجلد في نفس مسار المصنف الحالي باسم Results يتم تصدير المصنفات به Sub YasserKhalil() Dim rngData As Range, rngToCopy As Range, arrFilter, I As Long, J As Long Application.DisplayAlerts = False Application.ScreenUpdating = False If Len(Dir(ThisWorkbook.Path & "\Results", vbDirectory)) = 0 Then MkDir ThisWorkbook.Path & "\Results" End If Set rngData = Range("D7:S" & Cells(Rows.Count, "D").End(xlUp).Row) arrFilter = Application.Transpose(Range("U12:U" & Cells(Rows.Count, "U").End(xlUp).Row)) ReDim Preserve arrFilter(1 To UBound(arrFilter) + 1) arrFilter(UBound(arrFilter)) = "<>بدون توجيه" For I = 1 To UBound(arrFilter) ActiveSheet.AutoFilterMode = False rngData.AutoFilter Field:=16, Criteria1:=arrFilter(I) J = rngData.Columns(1).SpecialCells(xlCellTypeVisible).Count If J = 1 Then GoTo skipper Set rngToCopy = Intersect(Union(Columns("D:E"), Columns("R:S")), rngData.SpecialCells(xlCellTypeVisible)) Workbooks.Add ActiveSheet.Cells.Clear rngToCopy.Copy Range("B5") With Range("B2:E3") .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .MergeCells = True .Font.Size = 20 .Value = IIf(I < UBound(arrFilter), arrFilter(I), "قوائم التوجهات الكلية") End With If I < UBound(arrFilter) Then Columns("E").Delete ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Results\" & arrFilter(I) & ".xlsx" Else ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Results\" & "قوائم التوجهات الكلية" & ".xlsx" End If ActiveWorkbook.Close skipper: Next I ActiveSheet.AutoFilterMode = False Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub تقبل تحياتي Export Workbooks Using Filter Method.rar

هذا السطر للتعديل في مسار المصنف Set WB = Workbooks.Open(ThisWorkbook.Path & "\" & "1.xlsx") هتشيل الجزء التالي ThisWorkbook.Path وتضع مسار المصنف بين أقواس تنصيص *************************** بالنسبة لو هتتعامل مع ورقة عمل أخرى يمكنك التعديل في الجزء ActiveSheet WB.ActiveSheet بأن تستخدم كلمة Sheets ثم افتح قوس ثم علامات تنصيص وتكتب اسم ورقة العمل ثم تغلق علامات التنصيص ثم تغلق الأقواس Sheets("Data") بفرض أن ورقة العمل اسمها Data ************************ بالنسبة للرسالة ضعها في السطر قبل السطر الأخير End Sub

جرب الملف المرفق auto copy.rar

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

حسناً ارفق ملف به كذا ورقة إذن صرف وضع بعض البياناات والأرقام الوهمية لمحاولة الوصول للمطلوب