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

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

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

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

الأخت الكريمة ربا إليك الكود التالي عله يفي بالغرض Sub SearchSheets() Dim Cel As Range, strSheet As String, strAddress As String For Each Cel In Sheet4.Range("B3:B" & Sheet4.Cells(Rows.Count, 2).End(xlUp).Row) strSheet = Cel.Value: strAddress = Cel.Offset(, 1).Value If Evaluate("ISREF('" & strSheet & "'!A1)") And strAddress <> "" Then Cel.Offset(, -1).Value = Sheets(strSheet).Range(strAddress).Value Next Cel End Sub

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

بارك الله فيك أخي الحبيب مختار أعتقد المشكلة ليست في الـ Color أو ColorIndex إنما المشكلة في الخاصية DisplayFormat حيث لا تعمل مع النسخ القديمة جزيت خيراً على مساهماتك القيمة والممتعة تقبل تحياتي

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

أخي الكريم (اللي مش عارف اسمه) وقلت له يغير اسمه لاسم يعبر عن شخصه الكريم إليك الكود التالي عله يعمل على 2007 Sub CountColoredCellsCF() Dim Ws As Worksheet, I& For Each Ws In ThisWorkbook.Worksheets I = I + CountCFCells(Ws.Range("I6").CurrentRegion, 6) Next Ws MsgBox "عدد الخلايا الصفراء يساوي = " & I End Sub Function CountCFCells(Rng As Range, ColorIndex As Long) As Long Dim I&, J&, Tmp$, Str1$ Dim CfCell As Range Dim FC As FormatCondition, IIFlg As Boolean For Each FC In Rng.FormatConditions If FC.Interior.ColorIndex = ColorIndex Then Exit For Next FC If FC Is Nothing Then Exit Function Str1 = FC.Formula1 For I = 1 To Len(Str1) Tmp = Mid(Str1, I, 1) If ("0123456789" Like "*" & Tmp & "*") Then IIFlg = True Else If IIFlg Then Exit For End If Next I Tmp = Right(Str1, Len(Str1) - I + 1) For Each CfCell In Rng Str1 = "=" & CfCell.Address & Tmp If Rng.Worksheet.Evaluate(Str1) = True Then J = J + 1 Next CfCell CountCFCells = J End Function تقبل تحياتي

نعم فكرتك قد تحل المشكلة بشكل كبير وتمنع التكرار ويصبح لديك مفتاح أساسي يمكن من خلاله البحث عن القيمة المطلوبة اعتماداً على العمود المساعد يمكنك استخدام الدالة Concatenate لتؤدي الغرض إن شاء الله وفقك الله

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

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

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

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

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

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

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

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

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

أخي الكريم يرجى تغيير اسم الظهور ليعبر عن شخصكم الكريم إليك الكود التالي عله يفي بالغرض Sub CountCells() Dim Ws As Worksheet, Cel As Range, I As Integer Set Ws = ActiveSheet Application.ScreenUpdating = False For Each Ws In ThisWorkbook.Worksheets For Each Cel In Ws.Range("I7:I" & Ws.Cells(Rows.Count, "I").End(xlUp).Row) If GetCellColorForReals(Cel) = 65535 Then I = I + 1 Next Cel Next Ws If I = 0 Then MsgBox "لا يوجد خلايا ملونة", 64 Else MsgBox "عدد الخلايا الملونة يساوي " & I End If Application.ScreenUpdating = False End Sub Function GetCellColorForReals(R As Range) As Long GetCellColorForReals = R.DisplayFormat.Interior.Color End Function تقبل تحياتي

أخي الكريم مهند لما لا تطرح موضوع جديد لتجد استجابة أكثر مع التوضيح التام لطلبك مع إرفاق لشكل النتائج المتوقعة إذا تطلب الأمر أخي الحبيب رجب جاويش حاول أن تبتعد قدر الإمكان عن الحلقات التكرارية لما لها من أثر في بطء عمل الكود خصوصاً إذا كانت البيانات كبيرة ما رأيك بفكر جديد وهو استخدام خاصية الفلترة ..جرب الكود التالي Sub HideRowsUsingFilterMethod() Dim Rng As Range Application.ScreenUpdating = False On Error Resume Next With ActiveSheet .AutoFilterMode = False .Range("C12:C65512").AutoFilter Field:=1, Criteria1:="=0", Operator:=xlOr, Criteria2:="" Set Rng = .Range("C13:C65512").SpecialCells(xlCellTypeVisible) .AutoFilterMode = False Rng.EntireRow.Hidden = True End With Application.ScreenUpdating = True End Sub تقبل تحياتي

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

المتغير X يشير إلى قيمة الخلية G13 التي بها رقم الإيصال فإذا كان فارغاً أو القيمة صفر ظهرت رسالة بأنه يجب ألا تكون الخلية فارغة وإذا لم لم يكن يساوي صفر ينفذ الكود

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

أخي الكريم أبو عبد الرحمن على حسب علمي لا يوجد خاصية صناديق الاختيار داخل قائمة الكومبوبوكس جرب الملف التالي عله يكون المطلوب لك ..سيتم إنشاء صناديق اختيار بمجرد تشغيل الفورم .. قم فقط بإنشاء زري أمر أحدهما باسم cmdExit للخروج من الفورم والآخر باسم cmdReport لإظهار الحقول المطلوبة فقط .. أرجو أن يفي بالغرض Private Sub cmdReport_Click() Dim Ctrl As Control, FoundCol Sheet1.Columns("A:T").EntireColumn.Hidden = False Sheet1.Columns("A:R").EntireColumn.Hidden = True For Each Ctrl In UserForm1.Controls If TypeName(Ctrl) = "CheckBox" Then If Ctrl.Value = True Then FoundCol = Application.Match(Ctrl.Caption, Sheet1.Rows(1), 0) If IsNumeric(FoundCol) Then Columns(FoundCol).Hidden = False End If End If Next Ctrl Application.Goto Sheet1.Range("A1") End Sub Private Sub UserForm_Initialize() Dim LastColumn As Long Dim I As Long Dim chkBox As MSForms.CheckBox LastColumn = 18 For I = 1 To LastColumn Set chkBox = Me.Controls.Add("Forms.CheckBox.1", "CheckBox_" & I) chkBox.Caption = Sheet1.Cells(1, I).Value chkBox.Left = 20 chkBox.Top = 5 + ((I - 1) * 20) Next I End Sub Private Sub cmdExit_Click() Unload Me End Sub تقبل تحياتي Create CheckBoxes On UserForm By Cells In Specific Range YasserKhalil.rar

أخي الحبيب عبد العزيز السر في الاسم (يا سر ...) تقبل وافر تقديري واحترامي