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

**الـعيدروس** · مايو 25, 2011

السلام عليكم

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

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

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

**عبدالله المجرب** · مايو 25, 2011

السلام عليكم

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

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

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

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

ابواحمد

العيدروس.rar

**الـعيدروس** · مايو 26, 2011

السلام عليكم

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

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

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

منتظر ردك

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

جلب بيانات.rar

**الـعيدروس** · يونيو 30, 2011

الرفع

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

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

**الـعيدروس** · يونيو 30, 2011

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

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

**الـعيدروس** · يوليو 1, 2011

السلام عليكم

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

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

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

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

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

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

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

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

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

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

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

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

هذا الكود

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

**الـعيدروس** · يوليو 1, 2011

السلام عليكم

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

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

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

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

**احمدزمان** · يوليو 1, 2011

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

اخي ابو نصار

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

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

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

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

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

نعمل الكود

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

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

= = = = = =

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

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

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

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

و اكرر

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

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

**الـعيدروس** · يوليو 1, 2011

السلام عليكم

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

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

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

جزاك الله خير

**محمد يحياوي** · يوليو 1, 2011

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

**الـعيدروس** · يوليو 1, 2011

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

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

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

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

**احمدزمان** · يوليو 1, 2011

السلام عليكم

اخي ابو نصار

ارجو المعذرة

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

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

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

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

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

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

مع التحية

**الـعيدروس** · يوليو 2, 2011

السلام عليكم

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

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

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

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

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

**احمدزمان** · يوليو 2, 2011

السلام عليكم

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

مع التحية

**الـعيدروس** · يوليو 2, 2011

السلام عليكم

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

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

مختصرا جدا

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

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

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

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

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

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

الكمبوكس هو عبارة عن فرز من ورقة 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

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

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

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

شكرك لك

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

**احمدزمان** · يوليو 2, 2011

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

اخي ابو نصار

اولا

اود ان اوضح

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

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

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

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

= = = = = =

في رأيي

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

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

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

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

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

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

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

توني تذكرت

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

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

الأخ كيماس

في 3 اجزاء

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

ممكن ترجع له

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

**احمدزمان** · يوليو 2, 2011

السلام عليكم

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

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

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

رغم غيابه

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

**الـعيدروس** · يوليو 2, 2011

السلام عليكم

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

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

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

شكر لك

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

**احمدزمان** · يوليو 2, 2011

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

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

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

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

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

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

تسجيل الدخول

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

الردود الموصى بها

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

من فضلك سجل دخول لتتمكن من التعليق

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information