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

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

وعليكم السلام جرب الكود بالشكل التالي Option Explicit Private Sub UserForm_Initialize() Dim sh As Worksheet Dim i As Integer Dim valeurs1 As Variant Dim sDic1 As Object Set sh = Sheets("add") Set sDic1 = CreateObject("Scripting.Dictionary") With Application .ScreenUpdating = False .DisplayAlerts = False End With With sh valeurs1 = .Range("C2:C" & .Cells(Rows.Count, 3).End(xlUp).Row).Value valeurs1(1, 1) = "الكل" For i = LBound(valeurs1) To UBound(valeurs1) If Not IsEmpty(valeurs1(i, 1)) Then sDic1(valeurs1(i, 1)) = "" Next i End With If IsArray(valeurs1) Then Me.ComboBox4.List = sDic1.keys With Application .ScreenUpdating = True .DisplayAlerts = True End With End Sub

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

وعليكم السلام بالقسمة على 10 ستحصل على النتيجة المطلوبة ، وهكذا ..

وعليكم السلام جرب السطر التالي بدلاً من السطر الذي فيه المشكلة Range("AH" & x).Value = Application.WorksheetFunction.Sum(Range("AG" & x).Value, 366)

وعليكم السلام جرب الكود التالي (لم أجربه لأنه لا يوجد ملف مرفق) ،والطلب غير واضح حيث يجب تحديد اسم المصنف الحالي واسم ورقة العمل والنطاق المطلوب التعامل معه ، وكذلك المصنف الآخر المطلوب نسخ البيانات إليه وورقة العمل والنطاق المطلوب نسخ البيانات إليه ... عموماً جرب الكود وغير ما يلزم (المهم هنا الفكرة) Sub zayed_allaw() Const strInput = "TIME SHET ZAYED.xlsx" Application.ScreenUpdating = False ThisWorkbook.Sheets("Sheet1").Range("A1:X19").Copy On Error Resume Next Set wbk = Workbooks(strInput) If wbk Is Nothing Then Set wbk = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & strInput) If wbk Is Nothing Then MsgBox strInput & " Not Found!", vbCritical End If End If Windows("TIME SHET ZAYED.xlsx").Activate Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("A1").Select Windows("TIME SHEET TAREK EK 2017.xlsb").Activate Application.CutCopyMode = False Range("A1").Select Application.ScreenUpdating = True End Sub

وعليكم السلام جرب الكود التالي Private Sub UserForm_Initialize() Label1.Caption = Format(Label1.Caption, "#,###.##") End Sub

وجزيت خيراً بمثل ما دعوت لي أخي الغالي مجدي يونس تقبل تحياتي

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

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

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

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

بسم الله ما شاء الله عمل رائع أخي العزيز محمد أبو صهيب أعجبني الملف بشكل كبير ، وإن كنت أفضل أن يكون مجلد الصور في نفس مسار المصنف الحالي .. ThisWorkbook.Path & "/Picture" عموماً الملف ممتاز ..بارك الله فيك وجزاك الله خيراً

بارك الله فيك أخي الغالي زيزو .. كود رائع وممتاز باستخدام المصفوفات بالرغم من أنه يمكن حل المشكلة باستخدام الفلترة ثم نسخ الصفوف الظاهرة فقط أو باستخدام التصفية المتقدمة Advanced Filter ولكني أعشق التعامل مع المصفوفات فقمت بنسخ كودك الرائع وتحويله لإجراء عام يمكن الاعتماد عليه بشكل عام .. حيث يمكن التغيير في 6 أسطر كما هو موضح في التعليقات المصاحبة للكود ... بعدها يمكن تنفيذ الكود بسهولة Sub Test() Dim wsSource As Worksheet Dim wsTarget As Worksheet Dim rng As Range Dim rn As Range Dim colCr As Long Dim str As String Set wsSource = Sheets("Sheet1") 'Source Sheet Set wsTarget = Sheets("Sheet2") 'Target Sheet Set rng = wsSource.Range("A3:E" & wsSource.Cells(Rows.Count, 1).End(xlUp).Row) 'Data Range Set rn = wsTarget.Range("A4") 'Results Range colCr = 5 'Criteria Column str = wsSource.Range("E1").Value 'Criteria String TransferDataUsingArrays wsSource, wsTarget, rng, rn, colCr, str End Sub Sub TransferDataUsingArrays(sSheet As Worksheet, tSheet As Worksheet, sRange As Range, tRange As Range, colCrit As Long, strCrit As String) Dim arr As Variant Dim temp As Variant Dim p As Long Dim i As Long Dim j As Long Dim x As Long Application.ScreenUpdating = False With tSheet With .Range(.Cells(tRange.Row, tRange.Column), .Cells(Rows.Count, sRange.Columns.Count)) .ClearContents .Font.Bold = False .Font.ColorIndex = xlAutomatic .Interior.Color = xlNone .Borders.LineStyle = False End With With .Cells(tRange.Row, tRange.Column).Resize(, sRange.Columns.Count) .Value = sSheet.Cells(sRange.Row, sRange.Column).Resize(, sRange.Columns.Count).Value .Font.Bold = True .Font.Color = vbRed .Interior.Color = vbCyan End With End With arr = sRange.Value ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2)) For i = 2 To UBound(arr, 1) If arr(i, colCrit) Like "*" & strCrit & "*" Then p = p + 1 For j = 1 To UBound(arr, 2) temp(p, j) = arr(i, j) Next j End If Next i If p > 0 Then tRange.Offset(1).Resize(p, UBound(temp, 2)).Value = temp tRange.Resize(p + 1, UBound(temp, 2)).Borders.LineStyle = True For i = sRange.Column To sRange.Columns.Count tRange.Offset(, 0 + x).ColumnWidth = sSheet.Columns(i).ColumnWidth x = x + 1 Next i Application.ScreenUpdating = True End Sub

رائع أخي الغالي أبو عيد (معادلة في منتهى الروعة والإبداع) لتحويل المعادلة لكود يمكن ببساطة استخدام كلمة Formula للنطاق المطلوب ووضع المعادلة مع تغييرات بسيطة اطلع على الكود التالي وتعلم كيف يمكن تحويل المعادلة إلى كود Sub Test() With ActiveSheet .Range("BN4:BN8").Formula = "=IFERROR(IF(OR(BM4="""",L4="""",L4=""1"",L4=""OFF""),"""",CHOOSE(L4,"""",""خطأ"",BM4+366,""خطأ"",BM4+545,""خطأ"",BM4+730)),"""")" .Range("BO4:BO8").Formula = "=IFERROR(IF(OR(BM4="""",L4="""",L4=""1"",L4=""OFF""),"""",CHOOSE(L4,"""",""خطأ"",BM4+545,""خطأ"",BM4+730,""خطأ"",BM4+910)),"""")" .Range("BN4:BO8").Value = .Range("BN4:BO8").Value End With End Sub

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

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

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

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

جرب الكود التالي Sub Test() Dim sh As Worksheet Dim shResult As Worksheet Dim lr As Long Dim last As Long Application.ScreenUpdating = 0 Set shResult = Sheets("ورقة النتائج") For Each sh In ThisWorkbook.Worksheets If Left(sh.Name, 3) = "IBC" Then lr = sh.Cells(Rows.Count, 3).End(xlUp).Row last = shResult.Cells(Rows.Count, 3).End(xlUp).Row + 1 If sh.Range("C4").Value <> "" Then sh.Range("C4:E" & lr).Copy shResult.Range("C" & last).PasteSpecial xlPasteValues End If End If Next sh Application.CutCopyMode = 0 Application.ScreenUpdating = 1 End Sub

بسم الله ما شاء الله عليك يا عربي متميز كالعادة .. إضافة بسيطة لمسح الصور في حالة عدم وجود الاسم Private Sub Worksheet_Change(ByVal Target As Range) Dim myPath As String, fullImagePath As String If Target.Address = "$B$1" Then myPath = ThisWorkbook.Path & "\pic\" fullImagePath = myPath + [B1] On Error GoTo Skipper Image1.Picture = LoadPicture(fullImagePath & "1.JPG") Image2.Picture = LoadPicture(fullImagePath & "2.JPG") Image3.Picture = LoadPicture(fullImagePath & "3.JPG") Image4.Picture = LoadPicture(fullImagePath & "4.JPG") Exit Sub End If Skipper: Image1.Picture = LoadPicture("") Image2.Picture = LoadPicture("") Image3.Picture = LoadPicture("") Image4.Picture = LoadPicture("") End Sub

وعليكم السلام يمكن استخدام دالة معرفة بالشكل التالي '=NumberOut(A2) Function NumberOut(rng As Range) Dim i As Integer For i = 1 To Len(rng) Select Case Asc(Mid(rng.Value, i, 1)) Case 0 To 64, 123 To 197 Case Else NumberOut = NumberOut & Mid(rng.Value, i, 1) End Select Next i End Function

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

بس خلاص ..إنت تؤمر أخي العزيز خالد تقبل تحياتي

وعليكم السلام ارفق ملف لتتضح صورة طلبك بشكل أفضل ..