عبدالله باقشير

السلام عليكم عيدكم مبارك وكل عام وانتم بخير بعد اذن اخي الحبيب طارق حفظه الله ائراءا للموضوع عندي كود في احد ملفاتي يقوم بمثل هذا الطلب مع تغيير بسيط في الكود Option Explicit '////////////////////////////////////////////////////// Sub kh_AddNamePicture() Dim MyObj, MyObjFol, Obj Dim MySheet As Worksheet Dim iPath As String, iName As String Dim Last As Long, i As Long '============================ On Error GoTo Err_kh_Files '============================ iPath = ActiveWorkbook.Path & "\MyImage\" Set MyObj = CreateObject("Scripting.FileSystemObject") Set MyObjFol = MyObj.GetFolder(iPath) '============================ Set MySheet = ThisWorkbook.Worksheets("Sheet1") Last = MySheet.Cells(Rows.Count, "Z").End(xlUp).Row '============================ For Each Obj In MyObjFol.Files If Not Dir(Obj.Path, vbDirectory) = "" Then iName = Left(Obj.Name, InStrRev(Obj.Name, ".") - 1) With MySheet If WorksheetFunction.CountIf(.Range("Z2").Resize(Last), iName) = 0 Then i = i + 1 .Cells(Last + i, "Z").Value = iName End If End With End If Next '============================ Err_kh_Files: If Err Then MsgBox "Err.Number:" & vbCr & Err.Number: Err.Clear Set MySheet = Nothing: Set MyObj = Nothing: Set MyObjFol = Nothing End Sub لعلكم تجدون فيه ضالتكم ولتعم الفائدة تقبلوا تحياتي وشكري

السلام عليكم بارك الله فيك اخي الحبيب رجب عمل اكثر من رائع اثابك الله في الشهر الكريم اضعاف مضاعفة تقبل تحياتي وشكري ولائراء الموضوع ممكن بالمعادلة SUMPRODUCT =SUMPRODUCT(N(INDEX(MyRng;0;7)=D$3);N(INDEX(MyRng;0;3)=$B5);INDEX(MyRng;0;4)) حيث النطاق MyRng =الصادر!$O$5:$U$100 المرفق 2003 بالمعادلات.rar تحميل من المدونة في الرابط http://khboor.posterous.com/sumproduct-92926

عند تحميلك للملف هل وجدت فيه حماية ؟؟

السلام عليكم خواتم مباركة اخي الحبيب الزير ---------------حفظه الله اخي الحبيب طاهر---------------حفظه الله اخي الحبيب محمد صالح---------------حفظه الله اخي الحبيب يحي حسين ---------------حفظه الله جزاكم الله خيرا وبارك فيكم تقبلوا تحياتي وشكري

السلام عليكم والشكر واصل لاخي الحبيب رجب شاهد الرابط التالي http://www.officena.net/ib/index.php?showtopic=42853

السلام عليكم كود لتحويل المعادلات الى اكواد في اي ورقة هذا شرح مبسط للموضوع معاك معادلات في ورقة معينة لجدول فرضا تبدا من الصف 5 وتنتهي بالصف 1000 متجاورة او غير متجاورة على الصف تنسخ هذه المعادلات وتضعها على صف في بداية الورقة مثلا 2 وتقوم باخفاء هذا الصف عمل الكود يتلخص في الاتي: يقوم بتشغيل هذه المعادلات في الصفوف التي عينتها في الكود ويبقي قيمتها فقط . وممكن تكرر هذا الاجراء على اي اوراق تريدها ويشغلها الكود دفعة واحده لكل الاوراق التي عينتها في الكود مثال kh_cFormula Range("ورقة1!$D$2:$G$2"), 5, 1000 Sub kh_cFormula(MyRng As Range, iRow As Integer, Lastrow As Long) ' MyRng : الصف المخفي الذي يحوي المعادلات ملحوق باسم الورقة ' iRow : اول صف للبيانات ' Lastrow : آخر صف للبيانات ====================================================================== الكود : Sub kh_Copy_Formula() On Error GoTo kh_Err kh_Application False '============================================= kh_cFormula Range("ورقة1!$D$3:$G$3"), 9, 18 kh_cFormula Range("ورقة2!$D$4:$G$4"), 10, 44 kh_cFormula Range("ورقة3!$D$5:$G$5"), 11, 20 '============================================= kh_Err: kh_Application True If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear Else: MsgBox " تم نسخ المعادلات بنجاح", vbMsgBoxRight, "الحمدلله" End If End Sub وهذا كود التحويل ' MyRng : الصف المخفي الذي يحوي المعادلات ملحوق باسم الورقة ' iRow : اول صف للبيانات ' Lastrow : آخر صف للبيانات Sub kh_cFormula(MyRng As Range, iRow As Integer, Lastrow As Long) Dim Col As Range Dim R As Long '======================== For Each Col In MyRng.Cells If Col.HasFormula Then For R = iRow To Lastrow With MyRng.Worksheet .Cells(R, Col.Column).FormulaR1C1 = Col.FormulaR1C1 .Cells(R, Col.Column).Value = .Cells(R, Col.Column) End With Next R End If Next '======================== Set Col = Nothing End Sub المرفق 2003-2007 كود لتحويل المعادلات الى اكواد في اي ورقة.rar

السلام عليكم باستخدام المعادلات =HYPERLINK(CONCATENATE(NAMEFIL;"A";ROWEND);"END") المرفق 2003-2007 text.rar

الله يكرمكم دنيا واخرة وخواتم مباركة تقبل تحياتي وشكري

الله يكرمكم دنيا واخرة وخواتم مباركة تقبل تحياتي وشكري

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

السلام عليكم ورحمة الله وبركاته احبتي في الله الاخ الفاضل / أيسم إبراهيم__________ حفظه الله الاخ الفاضل / محمد مصطفى ابو حمزة__________ حفظه الله الاخ الفاضل / الزير__________ حفظه الله الاخ الفاضل / ابو سارة__________ حفظه الله خواتم مباركة وكل عام وانتم بخير اكرمكم الله واثابكم بدعائكم واعطاكم بمثله اضعاف مضاعفة تقبلوا تحياتي وشكري

السلام عليكم خواتم مباركة العمل هذا يحتاج تفريغ كامل وحاليا لست جاهزا له تقبل تحياتي وشكري

حفظك الله ورعاك واكرمك في الدارين و خواتم مباركة تقبل تحياتي وشكري

السلام عليكم بارك الله فيك اخي الحبيب بن عليه وخواتم مباركة تقبل تحياتي وشكري

السلام عليكم الشكر واصل للاخ محمود حفظه الله لائراء الموضوع استخدمت المعادلة التالية =VLOOKUP($J$1;OFFSET(MyDate;MATCH(I2;INDEX(MyDate;0;1);0);1);3;0) حيث النطاق MyDate =Sheet1!$D$1:$G$30000 المرفق 2003 2007 هام.rar

h تفضل الكود التالي: Sub kh_Start() Dim i As Long, ii As Long ii = 1 For i = 1 To 2000 Step 80 With Sheets("المطلوب") .Cells(ii, "A").Resize(40, 1).Value = Sheets("المعطى").Cells(i, 1).Resize(40, 1).Value .Cells(ii, "C").Resize(40, 1).Value = Sheets("المعطى").Cells(i + 40, 1).Resize(40, 1).Value End With ii = ii + 40 Next End Sub المرفق 2007 الشرح: For i = 1 To 2000 Step 80 السلسلة من 1 الى 2000 بمسافة 80 في الشيت المطلوب Sheets("المطلوب") في هذا الشيت نحتاج بكل دورة 40 صف للعمود A .Cells(ii, "A").Resize(40, 1).Value ونحتاج بكل دورة 40 صف للعمود C .Cells(ii, "C").Resize(40, 1).Value و بعد كل دورة تضاف 40 فوق المتغير ii ?ii = ii + 40 في الشيت المعطى لكل دورة اول 40 صف تعطى للعمود A من شيت المطلوب Sheets("المعطى").Cells(i, 1).Resize(40, 1).Value ما بعد 40 صف تعطى للعمود C من شيت المطلوب ?Sheets("المعطى").Cells(i + 40, 1).Resize(40, 1).Value ارجوا ان يكون شرحي مفهوم لديكم طلبنا الوحيد الدعاء Q.rar

السلام عليكم اجعل الكود التالي في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) Dim R As Integer If Not Intersect(Target.Cells, Range("B4:C13,E4:E13")) Is Nothing Then R = Target.Row Cells(R, "D").Value = Val(Cells(R, "B")) + Val(Cells(R, "C")) Cells(R, "F").Value = Val(Cells(R, "D")) + Val(Cells(R, "E")) Cells(R, "G").Value = Val(Cells(R, "F")) * 1 / 10 Cells(R, "H").Value = Val(Cells(R, "F")) + Val(Cells(R, "G")) End If End Sub ودمتم

السلام عليكم شهر مبارك وكل عام وانتم بخير وجزاكم الله خيرا وبارك فيكم تقبلوا تحياتي وشكري

تفضل واصبر سوق2-2.rar

تفضل هذا يستغرق حوالي 5 دقائق 2003 سوق2.rar

السلام عليكم اكرمك الله وكل عام وانتم بخير تقبل تحياتي وشكري

السلام عليكم وهذا كود آخر غير كود التصفية Sub kh_Start() Dim LastRow As Long, i As Long, ii As Long Dim SText As String Dim StDate As Date, EndDate As Date With Sheets("البحث") .Range("A7:L10000").ClearContents SText = .Range("B2") StDate = .Range("B3") EndDate = .Range("B4") End With ii = 7 With Sheets("yaomea") LastRow = .Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To LastRow If CStr(.Cells(i, "J")) = SText Then Select Case .Cells(i, "d").Value2: Case StDate To EndDate Sheets("البحث").Cells(ii, "A").Resize(1, 12).Value = .Cells(i, "A").Resize(1, 12).Value ii = ii + 1 End Select End If Next End With End Sub

السلام عليكم ضع المعادلة التالية في الخلية M3 =SUMPRODUCT((yaomea!$J$2:$J$10000=البحث!$B$2)*(yaomea!$D$2:$D$10000<البحث!$B$3);(yaomea!$K$2:$K$10000)-yaomea!$L$2:$L$10000) ودمتم في حفظ الله

اكرمك الله اخي الحبيب رجب تقبل تحياتي وشكري

الله اعلم قد يكون كتابتك للنطاق خطا حفظك الله