SPHINX

اخي العزيز كيف تكون المعادلة لو كان المطلوب تحقيق شرطين بمعنى لو كان 20 و 30 يكون جيد مثلا

استاذي تامر لا اريد ان اثقل عليك ولكن بالاشارة الى الكود المذكور فهو والحمد لله يعمل وفق للامكانيات المتاحه ولكن لي طلب صغير في حالة البحث هل يمكن ان يكون البحث باكثر من محدد وذا كان من الممكن عن الرغبة في التعديل هل يمكن التعديل على شيت البحث ومن ثم يتم التعديل في الشيت الاصليه

اخي الكريم الياس اشكركم جزيل الشكر وقد كنت انا وكثير من رواد المنتدى في حاجة ماسة لهذ الموضوع واجو ان تسمح لي في اضافة طلب صغير وهو كيفية اضافة زر بحث وتعديل بمعنى اننا قد قمنا بادخال بينات كثير وقد تصل الى 2000 صف و30 عمود كيف لي ان اقوم باضافة زر بحث عن بيان محدد في هذا المجال وعند الايجاد البيانات الكامله يقوم الفورم بعرض كافة بيانات الصف مع امكانية التعديل على خلايا محدده وما هو الامر في حالة حدوث وجود اكثر من بيان متطابق وهو امر عادي

الحبيب نامر اشكر لك مساعدتك ولكن اود ان اعرف لماذا سوف لا يعمل معي الكود في احتياجاتي المستقبليه واود ان اعرف كيفية عمل الكود Sub INQUR() Sheets("INQURY").Select ActiveSheet.Rows.Hidden = False [A3:AD500].ClearContents s = "" s = Application.InputBox("!&Atilde;&Iuml;&Icirc;&aacute; &Ccedil;&aacute;&szlig;&aacute;&atilde;&Eacute; &Ccedil;&aacute;&Ecirc;&iacute; &Ecirc;&aelig;&Iuml; &Ccedil;&aacute;&Egrave;&Iacute;&Euml; &Uacute;&auml;&aring;&Ccedil;", "&Egrave;&Iacute;&Euml;") If s = False Then Exit Sub If s = "" Then Exit Sub Application.ScreenUpdating = False With Sheets("TRCK").[A3:AD500] Set MySearch = .Find(s, LookAt:=xlWhole) If Not MySearch Is Nothing Then F = MySearch.Address MyRow = 3 Do x = MySearch.Row y = MySearch.Column For MyColumn = 1 To 30 Sheets("INQURY").Cells(MyRow, MyColumn) = Sheets("TRCK").Cells(x, MyColumn) Next MyColumn MyRow = MyRow + 1 Set MySearch = .FindNext(MySearch) Loop While Not MySearch Is Nothing And MySearch.Address <> F End If End With For a = 3 To 500 If Cells(a, 1) = "" Then Rows(a).Hidden = True Next ActiveWindow.SmallScroll Down:=-100 Application.ScreenUpdating = True 'If Application.WorksheetFunction.CountA([A3:S500]) = 0 Then ' MsgBox "!&aacute;&Ccedil; &iacute;&aelig;&Igrave;&Iuml; &Atilde;&iacute; &Egrave;&iacute;&Ccedil;&auml;&Ccedil;&Ecirc; &Iacute;&aelig;&aacute; &Ccedil;&aacute;&szlig;&aacute;&atilde;&Eacute; &Ccedil;&aacute;&Ecirc;&iacute; &Egrave;&Iacute;&Euml;&Ecirc; &Uacute;&auml;&aring;&Ccedil;", vbExclamation, "&Uacute;&Yacute;&Uuml;&aelig;&Ccedil;&eth;" 'Else: Msg = MsgBox("&aring;&aacute; &Ecirc;&aelig;&Iuml; &Oslash;&Egrave;&Ccedil;&Uacute;&Eacute; &auml;&Ecirc;&Ccedil;&AElig;&Igrave; &Ccedil;&aacute;&Egrave;&Iacute;&Euml;&iquest;", vbQuestion + vbYesNo, "&Ecirc;&Atilde;&szlig;&iacute;&Iuml; &Oslash;&Egrave;&Ccedil;&Uacute;&Eacute;") ' If Msg = vbYes Then PrintOut 'End If End Sub

يرجى الاطلاع على الكود الاتي [code]Sub INQUR() Sheets("INQURY").Select ActiveSheet.Rows.Hidden = False [A3:AD500].ClearContents s = "" s = Application.InputBox("!&Atilde;&Iuml;&Icirc;&aacute; &Ccedil;&aacute;&szlig;&aacute;&atilde;&Eacute; &Ccedil;&aacute;&Ecirc;&iacute; &Ecirc;&aelig;&Iuml; &Ccedil;&aacute;&Egrave;&Iacute;&Euml; &Uacute;&auml;&aring;&Ccedil;", "&Egrave;&Iacute;&Euml;") If s = False Then Exit Sub 'If s = "" Then Exit Sub Application.ScreenUpdating = False With Sheets("TRCK").[A3:AD2000] Set MySearch = .Find(s, LookAt:=xlWhole) If Not MySearch Is Nothing Then F = MySearch.Address Myrow = 3 Do x = MySearch.Row y = MySearch.Column For MyColumn = 1 To 30 Sheets("INQURY").Cells(Myrow, MyColumn) = .Cells(x, MyColumn) Next MyColumn Myrow = Myrow + 1 Set MySearch = .FindNext(MySearch) Loop While Not MySearch Is Nothing And MySearch.Address <> F End If End With For A = 50 To 1000 If Cells(A, 1) = "" Then Rows(A).Hidden = True Next ActiveWindow.SmallScroll Down:=-100 Application.ScreenUpdating = True If Application.WorksheetFunction.CountA([A3:AD500]) = 0 Then MsgBox "!&aacute;&Ccedil; &iacute;&aelig;&Igrave;&Iuml; &Atilde;&iacute; &Egrave;&iacute;&Ccedil;&auml;&Ccedil;&Ecirc; &Iacute;&aelig;&aacute; &Ccedil;&aacute;&szlig;&aacute;&atilde;&Eacute; &Ccedil;&aacute;&Ecirc;&iacute; &Egrave;&Iacute;&Euml;&Ecirc; &Uacute;&auml;&aring;&Ccedil;", vbExclamation, "&Uacute;&Yacute;&Uuml;&aelig;&Ccedil;&eth;" 'Else: Msg = MsgBox("&aring;&aacute; &Ecirc;&aelig;&Iuml; &Oslash;&Egrave;&Ccedil;&Uacute;&Eacute; &auml;&Ecirc;&Ccedil;&AElig;&Igrave; &Ccedil;&aacute;&Egrave;&Iacute;&Euml;&iquest;", vbQuestion + vbYesNo, "&Ecirc;&Atilde;&szlig;&iacute;&Iuml; &Oslash;&Egrave;&Ccedil;&Uacute;&Eacute;") 'If Msg = vbYes Then PrintOut End If End Sub ما يفعله الكود ان يقوم بالبحث عن الكلمة المراده وعند نسخ ولصق البيانات يهمل عدد صفين من فوق ويضيف صفين من تحت بذلت كافه المحاولات ولم اتوصل للحل فا اتوجه للسيد الاستاذ تامر عمر حيث انه العبقري صاحب الكود حيث ان اهل مكه ادرى بشعبها وقد بحثت في كافه المنتديات لم اجد في قوة وبساطة هذا الكود

للرفع

هل من مساعد

الاستاذ تامر اعرف انني اثقلت عليك بالكثير ولكن ليس لي ملجاء الا هذا المنتدى الرائع والذي تعلمت منه الكثير فيرجى مساعدتي

المعادلة بسيطه وهي = (today()-w5) وبعد ذلك عمل نسخ لنفس المعادلة في كامل العمود w

نعم هو المطلوب فانة عندما يتم تغير الخلية في العمود رقم 22 (V)الى Approved يكون تلوين الصف بدون لون ولكن عندما تكون قيمة طرح التواريخ في الخلية المتواجده في العمود رقم 30 (AD) والخلية الموجدة في العامود رقم 22 (V) سوف يتم تلوين كامل الصف مرة اخرى حتى اذا كانت Approved الى اي لون نحدده هل يوجد لديك اكواد الالوان

to change from lower or proper case to upper case هذا الكود لكامل ورقة العمل Private Sub Worksheet_Change(ByVal Target As Range) '''''''''''''''''''''''''''''''''''''''''''' 'Forces all text to UPPER case '''''''''''''''''''''''''''''''''''''''''''' If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub On Error Resume Next Application.EnableEvents = False Target = UCase(Target) Application.EnableEvents = True On Error GoTo 0 End Sub وفي حاله الرغبة بتحديد خلايا معينة يستخدم الكود الاتي Private Sub Worksheet_Change(ByVal Target As Range) '''''''''''''''''''''''''''''''''''''''''''' 'Forces text to UPPER case for the range A1:B20 '''''''''''''''''''''''''''''''''''''''''''' If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub On Error Resume Next If Not Intersect(Target, Range("A1:B20")) Is Nothing Then Application.EnableEvents = False Target = UCase(Target) Application.EnableEvents = True End If On Error GoTo 0 End Sub

استاذي لقد استخدمت الكود الاتي ولكن لاوال هناك مشكله عدم تحديث اللون في حالة ما اذا تغير خانة المعيار حيث ان خانة المعيار هي نتاج معادلة كما ذكرت سابقا Private Sub Worksheet_Change(ByVal Target As Range) Sheets("TRCK").Select ActiveWorkbook.DisplayDrawingObjects = xlAll Dim rng As Range 'column "v" = column 22 'On Error GoTo leave If Target.Column = 22 Then i = Target.Row Set rng = Range(Cells(i, 2), Cells(i, 23)) 'if you like it better, you could use: Set rng = Range("a" & i & ":ad" & i) Select Case Target.Value Case "sent", "SENT", "Sent" rng.Interior.ColorIndex = 6 Case "pending", "PENDING", "Pending" rng.Interior.ColorIndex = 3 Case "approved", "APPROVED", "Approved" rng.Interior.ColorIndex = 0 'Case "NON RET" ' rng.Interior.ColorIndex = 36 'Case "DUPL CALL" ' rng.Interior.Color = RGB(100, 0, 0) End Select End If If Target.Column = 30 Then i = Target.Row Set rng = Range(Cells(i, 2), Cells(i, 31)) 'if you like it better, you could use: Set rng = Range("a" & i & ":ad" & i) Select Case Target.Value Case Is > 179 rng.Interior.ColorIndex = 6 Case Is < 179 rng.Interior.ColorIndex = 0 End Select End If Application.ScreenUpdating = True 'leave: End Sub

لا حرمنى الله من ردودكم الثمينة :)

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

الاستاذ تامر لقد تم اقتباس الكود الاتي من احد روائعك ولكن يوجد لدي استفسار 1. عندما اقوم بالبحث عن بيان ما يقوم البرنامج بالعمل اللازم مع اضافة اشياء لم تكون موجوده في مجال البحث 2. هل نستطيع اضافة مجال البحث 3. عند البحث عن بيانات موجودة بعض الاوقات يرجع يرسال البيانات غير موجودة 4. لو ان تسمح لي بان اثقل عليك ببان كيف يتم البحث اي التسلسل للبحث ومجال البحث وهل البحث شامل الارقام والكلمات او الاثنين معا Sub INQURY() Sheets("Inqury").Select ActiveSheet.Rows.Hidden = False [A3:AC1000].ClearContents s = "" s = Application.InputBox("What are you searchin for !", "Search") If s = False Then Exit Sub If s = "" Then Exit Sub Application.ScreenUpdating = False With Sheets("TRCK").[A4:AC1000] Set MySearch = .Find(s, LookAt:=xlWhole) If Not MySearch Is Nothing Then F = MySearch.Address MyRow = 4 Do x = MySearch.Row y = MySearch.Column For MyColumn = 1 To 29 Sheets("Inqury").Cells(MyRow, MyColumn) = .Cells(x, MyColumn) Next MyColumn MyRow = MyRow + 1 Set MySearch = .FindNext(MySearch) Loop While Not MySearch Is Nothing And MySearch.Address <> F End If End With For A = 3 To 1000 If Cells(A, 5) = "" Then Rows(A).Hidden = True Next ActiveWindow.SmallScroll Down:=-100 Application.ScreenUpdating = True If Application.WorksheetFunction.CountA([A3:AB100]) = 0 Then MsgBox "!&aacute;&Ccedil; &iacute;&aelig;&Igrave;&Iuml; &Atilde;&iacute; &Egrave;&iacute;&Ccedil;&auml;&Ccedil;&Ecirc; &Iacute;&aelig;&aacute; &Ccedil;&aacute;&szlig;&aacute;&atilde;&Eacute; &Ccedil;&aacute;&Ecirc;&iacute; &Egrave;&Iacute;&Euml;&Ecirc; &Uacute;&auml;&aring;&Ccedil;", vbExclamation, "&Uacute;&Yacute;&Uuml;&aelig;&Ccedil;&eth;" 'Else: Msg = MsgBox("&aring;&aacute; &Ecirc;&aelig;&Iuml; &Oslash;&Egrave;&Ccedil;&Uacute;&Eacute; &auml;&Ecirc;&Ccedil;&AElig;&Igrave; &Ccedil;&aacute;&Egrave;&Iacute;&Euml;&iquest;", vbQuestion + vbYesNo, "&Ecirc;&Atilde;&szlig;&iacute;&Iuml; &Oslash;&Egrave;&Ccedil;&Uacute;&Eacute;") ' If Msg = vbYes Then PrintOut End If End Sub

استاذي لك كل التقدير لمساعدتك ولكن اعتقد انني لم استطيع اوضح المطلوب فلازالت لم يتم التعديل وذلك لانه ينطبق شرط التلوين فقط على الصف رقم 5 في العمود S وكل ماريده ان ينطبق على كل الصفوف فمثلا اذا كان ناتج عملية الطرح (عدد الايام ما بين تاريخين) الموجود في s5 or s8 or s8 or s9 وهكذا اكبر من او يساوي 180 يتم التظليل ارجو ان اكون قد اوضحت طلبي

استاذي تامر لقد توصلت للحل وذلك بعد الرجوع للمثال المرفق واحب ان افيد الاخوة ايضا فما تم عمله هو كالاتي بالرجوع الى مثالي السابق 280 كانت تمثل عدد الوحدات السنوية فقد تم تمثيل النسبة اي 80/280 = % وبعد ذلك يتم ضرب الناتج في النسب المذكورة

الاستاذ محمد حجازي تعقيب على المشاركة الاتية http://www.officena.net/ib/index.php?showtopic=7648 هل يمكن تقسيم رقم ما موضوع في خلية ما ولتكن A1 بنسب متفاوته في صفوف من B1 الى B8 بحيث يكون مجموع b1 الى B8 رقم اخر للتوضيح فرضا يوجد لدي رقم 280 اريد تقسيمه على 8 صفوف تبدأ من b1 : b8 بحيث تكون النسب كالاتي 18% و 18% و 15% و 12% و 12% و 12% و 8% و 5% على ان يكون مجموع b1:b2 مثلاً 80

الاحوة المشرفين هذه المشكلة تؤرقني عند تعطيل الماكرو يستطيع المستخدم الدخول علو ورقة العمل ويرى ما بها من بيانات هل هناك حل

الاخوة الفاضلين ردا على المشاركة الاتية http://www.officena.net/ib/index.php?showtopic=9281 يرجى العلم انه يوجد برنامج لضغط ملفات الاكسيل الكبير والنسخة الموجودة هي نسخة محدوده نطلب من الاخوة المشرفين والافاضل المساعدة في الحصول على النسخة الكامله والكمال لله setup.zip

استاذ تامر هل يجوز ذلك

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

نرحو الافادة كيف تم عملي البحث ما بين تاريخين

الاستاذ محمد طاهر لقد استخدمت الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 30 Then Exit Sub If Range("AD" & Target.Row).Value >= 90 Then Range("AD" & Target.Row).Offset(-3, -29).Range("A4:AC4").Interior.ColorIndex = 6 Else Range("AD" & Target.Row).Offset(-3, -29).Range("A4:AC4").Interior.ColorIndex = 0 End If End Sub ولكن اذا كانت الخلية التي يوجد بها معيار التحكم ناتجه عن معادله فان لا يقوم بتغير اللون الى غير مظلل اي عندما يكون ناتج المعادلة اكبر من او يساوي 90 يتم التظليل باللون الاصفر ولكن اذا تغير ناتج المعادلة ليصبح 5 او 10 لا يرجع اللون

لا اقصد تلوين الصفوف التي تنطبق عليها القيمة المذكوره ولو قلت القيمه يرجع للون الاصلي