الرجاء دمج الاضافات للكود

[الـعيدروس]

السلام عليكم

الاساتذه الاجلاء

اسعد صباحكم الرجاء دمج الاضافات على هذا الكود

Private Sub ComboBox1_Change()

Application.ScreenUpdating = False

[a3: ax2000].ClearContents

ورقة1.[a3:az3].AutoFilter

ورقة1.[a3:az3].AutoFilter Field:=6, Criteria1:=ComboBox1

ورقة1.Range("A4:Az2000").SpecialCells(xlCellTypeVisible).Copy

Range("a3").PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _

        xlNone, SkipBlanks:=False, Transpose:=False

ورقة1.[a3:az3].AutoFilter

x = Range("b15000").End(xlUp).Row + 1

Cells(x, "b") = "المجمـــــوع"

Cells(x, "c") = Application.WorksheetFunction.SUM(Range([c3], Cells(x, "c")))

Cells(x, "an") = Application.WorksheetFunction.SUM(Range([an3], Cells(x, "an")))

Cells(x, "ao") = Application.WorksheetFunction.SUM(Range([ao3], Cells(x, "ao")))

Cells(x, "aq") = Application.WorksheetFunction.SUM(Range([aq3], Cells(x, "aq")))

Cells(x, "aw") = Application.WorksheetFunction.SUM(Range([aw3], Cells(x, "aw")))

[d1].Select

'==============================

'الاستاذ القدير الحسامي الرجاء دمج الاضافات التاليه في الكود

'==============================

.Font.Size = 16 '=======

.Font.Bold = True '=======

.Font.ColorIndex = 5 '=======

.Borders.Weight = xlMedium '=======

.Borders.ColorIndex = 3 '=======

.Interior.ColorIndex = 36 '=======

.Columns.AutoFit '=======

.HorizontalAlignment = xlCenter '=======

.VerticalAlignment = xlCenter '=======

.RowHeight = 25 '=======

'==============================

End Sub

[عبدالله المجرب]

السلام عليكم

الاساتذه الاجلاء

اسعد صباحكم الرجاء دمج الاضافات على هذا الكود

اخي العيدروس نتمنى ان ترفق ملف به المطلوب

وهذا المرفق على حد ما فهمت (موجود في ورقة2)

ابواحمد

العيدروس.rar

[الـعيدروس]

السلام عليكم

الاستاذ القدير ولد المجرب

مشكور على تفاعلك في الموضوع

واما طلب موضحه على المرفق

منتظر ردك

والسلام عليكم

جلب بيانات.rar

[الـعيدروس]

الرفع

كنت سهيت عن الموضوع مع تصفحي صادفته

ههههه ارجو الافاده

[الـعيدروس]

للرفع يااساتذه الأكواد

الله يرفع قدركم

[الـعيدروس]

السلام عليكم

الاساتذه الافاضل توصلت الى حل

رغم كبر الكود ولاكن ادا مااريده

الاضافه هيا عند جلب تصنيف

بعد اخر صف يعمل جمع لاعمده محدده

ويقوم بعمل تنسيق خطين فوق بعض مع

خط معين وتوسيط ولون

================================

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

بالغاء التنسيق الاول الذي تم عمله

من الاجلب الاخير وبعد الجلب يقوم

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

=================================

هذا الكود

Private Sub ComboBox2_Change()

Range("a3:az" & Rows.Count).ClearContents

'ClearContents

Application.ScreenUpdating = False

[a3: ax2000].ClearContents

shtMain.[a3:az3].AutoFilter

shtMain.[a3:az3].AutoFilter Field:=6, Criteria1:=ComboBox2

shtMain.Range("A4:Az2000").SpecialCells(xlCellTypeVisible).Copy

Range("a3").PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _

xlNone, SkipBlanks:=False, Transpose:=False

shtMain.[a3:az3].AutoFilter

X = Range("b15000").End(xlUp).Row + 1

Cells(X, "b") = "المجمـــــوع"

Cells(X, "c") = Application.WorksheetFunction.SUM(Range([c3], Cells(X, "c")))

Cells(X, "an") = Application.WorksheetFunction.SUM(Range([an3], Cells(X, "an")))

Cells(X, "ao") = Application.WorksheetFunction.SUM(Range([ao3], Cells(X, "ao")))

Cells(X, "aq") = Application.WorksheetFunction.SUM(Range([aq3], Cells(X, "aq")))

Cells(X, "aw") = Application.WorksheetFunction.SUM(Range([aw3], Cells(X, "aw")))

[ba1].Select

'=================================================

Range("b1000").End(xlUp).Select ' تنسيق اخر صف فيه بيانات

'=================================================

'================================تحديد لون التعبئه

With Selection.EntireRow.Interior

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

.ThemeColor = xlThemeColorAccent6

.TintAndShade = 0.799981688894314

.PatternTintAndShade = 0

End With

'================================

Selection.EntireRow.Font.Bold = True

Selection.Font.Underline = xlUnderlineStyleSingle

With Selection.EntireRow.Font

.Name = "Traditional Arabic"

.Size = 12

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleSingle

.ThemeColor = xlThemeColorLight1

.TintAndShade = 0

.ThemeFont = xlThemeFontNone

End With

Selection.Font.Size = 12

Selection.Borders(xlDiagonalDown).LineStyle = xlNone

Selection.Borders(xlDiagonalUp).LineStyle = xlNone

With Selection.EntireRow.Borders(xlEdgeLeft)

.LineStyle = xlDouble

.ColorIndex = xlAutomatic

.TintAndShade = 0

.Weight = xlThick

End With

With Selection.EntireRow.Borders(xlEdgeTop)

.LineStyle = xlDouble

.ColorIndex = xlAutomatic

.TintAndShade = 0

.Weight = xlThick

End With

With Selection.EntireRow.Borders(xlEdgeBottom)

.LineStyle = xlDouble

.ColorIndex = xlAutomatic

.TintAndShade = 0

.Weight = xlThick

End With

With Selection.EntireRow.Borders(xlEdgeRight)

.LineStyle = xlDouble

.ColorIndex = xlAutomatic

.TintAndShade = 0

.Weight = xlThick

End With

With Selection.EntireRow.Borders(xlInsideVertical)

.LineStyle = xlDouble

.ColorIndex = xlAutomatic

.TintAndShade = 0

.Weight = xlThick

End With

Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

'===========================================توسيط الخط في الصف

With Selection.EntireRow

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlBottom

.WrapText = False

.Orientation = 0

.AddIndent = False

.IndentLevel = 0

.ShrinkToFit = False

.ReadingOrder = xlContext

.MergeCells = False

End With

With Selection.EntireRow

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.WrapText = False

.Orientation = 0

.AddIndent = False

.IndentLevel = 0

.ShrinkToFit = False

.ReadingOrder = xlContext

.MergeCells = False

End With

End Sub

ارجو التكرم من احد الاساتذه

بعمل الاضافه

تم تعديل يوليو 1, 2011 بواسطه alidroos

[الـعيدروس]

السلام عليكم

توصلت الى حل بكود عكسي

ارجو من لدية صلاحيه

يحذف المشاركه المكرره

والسلام عليكم

[احمدزمان]

السلام عليكم و رحمة الله وبركاته

اخي ابو نصار

طبعا المجهود الذي بذلته للكود رائع جدا - و مجهود كبير جزاك الله كل خير

بس عندي اقتراح اتمنى ان تتقبله و تطبقة

نحنة ممكن نستغل الإكسل من ناحية خاصية النسخ و اللصق الخاص للتنسيقات

نحدد نطاق مشابه للنطاق الهدف

نعمل فية التنسيقات يدويا زي مانبغة

نعمل الكود

يقوم بنسخ هذا النطاق

ولصق التنسيقات فقط لآخر صف

= = = = = =

الفائدة الإضافية من هذه العملية

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

آمل ان يكون اقتراحي هذا فيه الفائدة

وان تتقبله بصدر رحب

و اكرر

هذا ليس انقاص من مجهودك الرائع

جزاك الله كل خير

[الـعيدروس]

السلام عليكم

اشكرك استاذ احمد يعقوب

على الملخص المفيد

وهذا مايحتاجه من مثلنا كمبتدئ

جزاك الله خير

[محمد يحياوي]

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

[الـعيدروس]

الاخ الفاضل يحياوي

هذا مافعلته وعملت تعديل عليه

وزبط زي الحلاوى

شاكر لك مرورك العطر

[احمدزمان]

السلام عليكم

اخي ابو نصار

ارجو المعذرة

لم انتبه انك صاحب الطلب

و اعتقدت انك تضع حل لصاحب الطلب بالكود المرفق

اعذرني على تعجلي

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

وسوف تكون سريعة ومكونة من كود صغير

اكرر :wub: اعتذاري :wub:

مع التحية

[الـعيدروس]

السلام عليكم

استاذ احمد لا عليك

احنا الذي نتعذر

لاشغالك بطلبات واخذ من وقتك

تفضل هذا الكود

Private Sub ComboBox2_Change()

Range("a3:az" & Rows.Count).ClearContents

'ClearContents

Application.ScreenUpdating = False

[a3: ax2000].ClearContents

shtMain.[a3:az3].AutoFilter

shtMain.[a3:az3].AutoFilter Field:=6, Criteria1:=ComboBox2

shtMain.Range("A4:Az2000").SpecialCells(xlCellTypeVisible).Copy

Range("a3").PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _

xlNone, SkipBlanks:=False, Transpose:=False

shtMain.[a3:az3].AutoFilter

X = Range("b15000").End(xlUp).Row + 1

Cells(X, "b") = "المجمـــــوع"

Cells(X, "c") = Application.WorksheetFunction.SUM(Range([c3], Cells(X, "c")))

Cells(X, "an") = Application.WorksheetFunction.SUM(Range([an3], Cells(X, "an")))

Cells(X, "ao") = Application.WorksheetFunction.SUM(Range([ao3], Cells(X, "ao")))

Cells(X, "aq") = Application.WorksheetFunction.SUM(Range([aq3], Cells(X, "aq")))

Cells(X, "aw") = Application.WorksheetFunction.SUM(Range([aw3], Cells(X, "aw")))

[ba1].Select end sub

[احمدزمان]

السلام عليكم

Private Sub ComboBox2_Change()

Range("a3:az" & Rows.Count).ClearContents

'ClearContents

Application.ScreenUpdating = False

[a3: ax2000].ClearContents

shtMain.[a3:az3].AutoFilter

shtMain.[a3:az3].AutoFilter Field:=6, Criteria1:=ComboBox2

shtMain.Range("A4:Az2000").SpecialCells(xlCellTypeVisible).Copy

Range("a3").PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _

xlNone, SkipBlanks:=False, Transpose:=False

shtMain.[a3:az3].AutoFilter

X = Range("b15000").End(xlUp).Row + 1

Range("IU2").Copy


Range("A" & X & ":AZ" & X).PasteSpecial Paste:=xlPasteFormats


Cells(X, "b") = "المجمـــــوع"

Cells(X, "c") = Application.WorksheetFunction.SUM(Range([c3], Cells(X, "c")))

Cells(X, "an") = Application.WorksheetFunction.SUM(Range([an3], Cells(X, "an")))

Cells(X, "ao") = Application.WorksheetFunction.SUM(Range([ao3], Cells(X, "ao")))

Cells(X, "aq") = Application.WorksheetFunction.SUM(Range([aq3], Cells(X, "aq")))

Cells(X, "aw") = Application.WorksheetFunction.SUM(Range([aw3], Cells(X, "aw")))

[ba1].Select 


end sub

نظرا لأنني وجدتك مستخدم الورقة كلها حتى آخر خليةIV

لذلك تكون الخطة كـ التالي

تروح للخلية IU2

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

ثم تستخدم هذا الكود

رايح ينسخلك التنسيق الي سويته الى كامل الخلايا من A الى AZ لصف المجموع

آمل التجربة و اخباري بانتيجة

اهم شيء لاتنسى تنسيق الخلية IU2

مع التحية

[الـعيدروس]

السلام عليكم

الاستاذ القدير احمد يعقوب

الله يستر عليك دنيا واخره

مختصرا جدا

وهذا ماكان في مخيلتي من بديت طرح الموضوع

فحاولت اتوصل الى حلول بغشامتي

زي منت شايف كود ورقة كامله

اشكرك جدا على الاضافه الجميله

عندي تعديل بسيط على الكود وارجو منك

التقييم هل اصبت ام لا في التعديل

الكمبوكس هو عبارة عن فرز من ورقة data

الى ورقة3 على حسب معيار محدد من مدى الا وهي

6 تصنيفات

عند طلب تصنيف يقوم بعمل التنسيقات من الخليه

المحدده وعند جلب تصنيف اخر التنسيقات الاولى

موجوده في احد خلايا جلب التصنيف السابق

بمعنى اضفت لكي يقوم بااسترجاع التصنيف العادي

من خليه معينه في بداية الكود واخر الكود اضافتك

الجميله

هذا الكود

Private Sub ComboBox2_Change()

Sheets("data").Unprotect ("0500144134")

Range("b15000").End(xlUp).Select

Range("aq1").Copy

Range("A" & ":AZ").PasteSpecial Paste:=xlPasteFormats

Range("a3:az" & Rows.Count).ClearContents

'ClearContents

Application.ScreenUpdating = False

[a3: ax2000].ClearContents

shtMain.[a3:az3].AutoFilter

shtMain.[a3:az3].AutoFilter Field:=6, Criteria1:=ComboBox2

shtMain.Range("A4:Az2000").SpecialCells(xlCellTypeVisible).Copy

Range("a3").PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _

xlNone, SkipBlanks:=False, Transpose:=False

shtMain.[a3:az3].AutoFilter

X = Range("b15000").End(xlUp).Row + 1

Range("bd1").Copy


Range("A" & X & ":AZ" & X).PasteSpecial Paste:=xlPasteFormats


Cells(X, "b") = "ÇáãÌãÜÜÜÜÜæÚ"

Cells(X, "c") = Application.WorksheetFunction.SUM(Range([c3], Cells(X, "c")))

Cells(X, "an") = Application.WorksheetFunction.SUM(Range([an3], Cells(X, "an")))

Cells(X, "ao") = Application.WorksheetFunction.SUM(Range([ao3], Cells(X, "ao")))

Cells(X, "aq") = Application.WorksheetFunction.SUM(Range([aq3], Cells(X, "aq")))

Cells(X, "aw") = Application.WorksheetFunction.SUM(Range([aw3], Cells(X, "aw")))

[ba1].Select


End Sub

وهذا الجزء المضاف في بداية الكود

Range("b15000").End(xlUp).Select

Range("aq1").Copy

Range("A" & ":AZ").PasteSpecial Paste:=xlPasteFormats

والاول والاخير هذا درس جميل جدا

من سموك الكريم فتح ابواب في مخليتي

من كفائة الاكسل

شكرك لك

تلميذك أبو نصار

[احمدزمان]

و عليكم السلام و رحمة الله

اخي ابو نصار

اولا

اود ان اوضح

انني احب و احترم واقدر الأستاذ الكريم الحسامي

ولا انسى انني تعلمت منه الكثير

جزاه الله كل خير

وتبقى ذكراه الطيبة خالدة في حضورة وغيابة

= = = = = =

في رأيي

يوجد كود آخر كنت قد تعلمته من الأستاذ الفاضل - ابو تامر جزاه الله كل خير

والذي سماه التصفية المتقدمة للنطاقات

هذا الكود قد ينفعك اكثر من الحالي

حيث انه ينقل البيانات مع تنسيقاتها

وينقل لك بيانات الأعمدة التي تحددها انت حسب مسميات العامود

يعني تختار الحاجات الي تبغاها

و عتقد انه رايح ينفعك هنا اكثر

توني تذكرت

وهذا الموضوع الي نتكلم عنه

كان قد شرحة فيديو حول طريقة عمله

الأخ كيماس

في 3 اجزاء

وتناول شرحة بالتفصيل مع خصائص هذه الطريقة

ممكن ترجع له

مع التحية و التقدير

[احمدزمان]

السلام عليكم

وهذا رابط الشرح للأستاذ الفاضل كيماس

الرباط الخاص بـ شرح التصفية المتقدمة 3

جزاه الله كل خير

رغم غيابه

الا ان افضاله مازالت موجودة وتذكر

[الـعيدروس]

السلام عليكم

انا شاهدت فيديو الاستاذ كيماس

ولاكن لم اطلع عليه بدقه

انشاء الله اتابع الدروس واطبقها على عملي

شكر لك

دمت في حفظ الله ورعايته

[احمدزمان]

السلام عليكم و رحمة الله

اخي الفاضل ابو نصار

ارجو ان تسمحلي ان اسجل اعتراضي على هذا الجزؤ من الكود

Range("b15000").End(xlUp).Select

Range("aq1").Copy

Range("A" & 

":AZ").PasteSpecial Paste:=xlPasteFormats

طيب ليه

قلتلي لية

في هذه الحالة انته سوف تنسخ لكامل الأعمدة من الأول لللآخر صف

وهذا سوف يسبب كبر حجم الملف و ثقل الملف في التعامل و الحساب

و الأفضل ان تضعه في السطر بعد تحديد القيمة X وقبل وضع تنسيق صف المجموع

وتكون صيغته كـ التالي

Range("aq1").Copy

Range("A1:AZ" & X).PasteSpecial Paste:=xlPasteFormats

وهكذا سوف يتم وضع التنسيق للمساحة المستخدمة فقط

نع التحية و التقدير