Excel4Us

‏إظهار الرسائل ذات التسميات الأكواد. إظهار كافة الرسائل

عد الخلايا الملونة في الإكسيل

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

كما نعلم جميعا أن دوال العد في الإكسيل و التي عددها خمسة دوال :

تقوم بالعد بناء على قيمة الخلية و طبيعة محتواها و لا يوجد من هذه الدوال ما يقوم بعد الخلايا بناء على لونها, رغم حاجتنا لهذه المعادلة إلا أنها لم تضاف في معادلات الإكسيل, و لحل هذه النقطة نقوم بتعريف معادلة خاصة بها من خلال :
VBA
Visual Basic for Application
و هي تعرف بإسم
UDF
User Defined Function

و لعمل ذلك سنتبع الخطوات التالية :

من شاشة الإكسيل سنقوم بالضغط على Alt + F11
من تاب Insert نختار Module , و للإطلاع على الخطوات بشكل أكبر شرح تفصيلي لإضافة الكود
و ستظر لنا الشاشة التالية :

هنا سنقوم بكتابة الكود التالي:

Function COUNTCOULREDCELLS(CriRange As Range, MCri As Range) As Long

Dim c As Range

Dim CountC As Long

Application.Volatile

For Each c In CriRange

If c.Interior.ColorIndex = MCri.Interior.ColorIndex Then

COUNTCOULREDCELLS = COUNTCOULREDCELLS + 1

End If

Next c

End Function

ستكون بالشكل التالي

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

بعمل مثال بسيط كالتالي :

النقطة رقم 1 تمثل البيانات و التي تحتوي الخلايا الملونة
النقطة رقم 2 تمثل المعيار الذي سنحدده لعد الخلايا المشابهه
النقطة رقم 3 تمثل المعادلة التي قمنا ببرمجتها و تمثل الجزء الأول النطاق الي سنحدده و هو في مثالنا من $B$2:$B$10
و المتغير الثاني و يمثل المعيار و هو الخلية التي تحتوي اللون الذي سنقوم بالعد بناء عليه

=COUNTCOULREDCELLS($B$2:$B$10,D3)

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

لتحميل الملف من خلال الرابط من هنا

أتمنى أن تكون الفكرة قد إتضحت لكم.

دمتم في حفظ الله

يحيى حسين
Excel MVP

Image

مشكلة إختفاء التاب في الإكسيل

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

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

فا أسماء الصفحات ظاهره , و لكن المشكلة التي نتحدث عنها هي أن هذه التابات تختفي
فيصبح الشكل كالتالي :

فالصورتين أعلاه لنفس الملف

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

ثم من شاشة الخيارت التي ستظهر لنا نختار Advanced

ثم من ضمن المجموعة
Display Options for this workbook
نضع علامة صح على الخيار
Show Sheets Tab

و بذلك ستظهر التابات مجددا

الطريقة الثانية : أن تستخدم الكود البرمجي التالي ( و يا حبذا لو ان الأخوة المبرمجين أن يقوموا بوضعه في حدث BeforeClose ) حتى نضمن أن تعود الإعدادات كما كانت.
و هذا هو الكود

ActiveWindow.DisplayWorkbookTabs = True

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

أتمنى أن تكون الفكرة واضحة

دمتم في حفظ الله

يحيى حسين
Excel MVP

Image

كود: طباعة بطاقات الصنف لعدة سنوات وعدة أصناف

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

فكرة هذا الكود تقوم على وجود مصنف اكسيل به ورقتين
الورقة الأولى و اسمها Items
و بها ارقام الاصناف في العمود A
و اسماء الأصناف بالعمود B
و عدد الأصناف يفوق ال 300 صنف
و يوجد لدينا في الورقة الثانية Item Card
بطاقة صنف فارغة
نريد وضع التاريخ في الخلية C1 و الذي يمثل احدى السنوات من عام 2005 و حتى 2010
و في الخلية B2 رقم الصنف
و الخلية B3 اسم الصنف
و من ثم طباعة بطاقة الصنف
و ثم نغير السنة
حتى يتم طباعة 6 بطاقة للصنف الواحد و هي تمثل السنوات
و ثم الصنف التالي و نفس العملية
و هكذا حتى نقوم بهذه العملية لكل الاصناف
و لعمل ذلك بطريقة مختصرة و سريعة قمت بعمل هذا الكود

Sub Excel4Us()
Dim c As Range, ws As Worksheet, LR As Long, MyYear()
LR = Sheets("Items").Range("a" & Rows.Count).End(xlUp).Row
Set ws = Sheets("Item Card")
MyYear = Array("2005", "2006", "2007", "2008", "2009", "2010")
For Each c In Sheets("Items").Range("a2:a" & LR)
For i = LBound(MyYear) To UBound(MyYear)
With ws
.Range("c1").Value = MyYear(i)
.Range("b2").Value = c.Value
.Range("b3").Value = c.Offset(, 1).Value
.PrintOut
End With
Next i
Next c
End Sub

_________________

دمتم في حفظ الله

Image

كود لتعبئة الفارغات في مدى معين

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

اخواني كثيراً ما نستخدم عملية تعبئة الفارغات في مدى معين من خلال

تحديد المدى ثم Goto Special->Balnks

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

Ctrl + Enter

و كحل سريع و تطبيقاً على الجدول المرفق

Name	Sales
Yahya	14093
	30610
	53445
	11116
	10996
	14090
	5072
	34706
	48310
	28304
Ali	22790
	12835
	43276
	33596
	18973
	8207
	27507
	52039
Ahmad	49905
	11166
	6779
	5176
	42371
	31762
	24678
	36906
	29631
	22241
	48708
Yousef	27656
	26368
	35568
	22388
	5028
	11608
	10290
	6918
	17386
	15403
	11378
	13747
	2050
	44306
	38056
Hani	38531
	40220
	32149
	5189
	43689
	41854
	37531
	26522
	41146
	24330
	18642
	8150
	9142
	25925

سنجرب الكود التالي:

Sub FillMyList()
'www.Excel4Us.com
Dim LastR As Long
LastR = Range("b" & Rows.Count).End(xlUp).Row
Range("A1:A" & LastR).SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
End Sub

============
أتمنى لكم المتعة و الفائدة
===========
دمتم في حفظ الله
يحيى حسين

Image

كود لجعل اللغة العربية في العامود الأول واللغة الإنجليزية في العامود الثاني

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

كثيراً ما نحتاج في أعمالنا التنقل ما بين اللغتين العربية و الإنجليزية
فنجد أنفسنا بحاجة لإستخدم مفاتيح الإختصار
Ctrl+Shift
من جهة اليمين للتحويل للغة العربية
Ctrl+Shift
من جهة الشمال للتحويل للغة الإنجليزية

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

Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long
Sub ChaingeLanguage(KBLang As String)
Dim pwszKLID As String
Select Case KBLang
Case "Arabic"
pwszKLID = "00000401"
Case "English"
pwszKLID = "00000409"
End Select
LoadKeyboardLayout pwszKLID, 1
End Sub

و في حدث فتح الصفحة ضع الكود التالي:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 1 Then
ChaingeLanguage "Arabic"
Else
ChaingeLanguage "English"
End If
End Sub

و لتحميل الملف من خلال الرابط التالي:
http://excel4us.com/vb/showthread.php?t=2208

مع العلم أن هذا الكود من إبداعات الأخ أبو تامر
مع تمنياتي لكم بالمتعة و الفائدة

Image

كود "لجمع" أو "عد" - Bold cells

السلام عليكم و رحمة الله و بركاته
طلب مني احد الاخوة كود لجمع الخلايا المعمول لها
BOLD
و قمت بعمل هذا الكود بالإعتماد على خاصية
Bold
المرتبطة بالخط
Font

و هذا هو الكود:

Function SUMBOLD(MyRng As Range) As Long

    Application.Volatile

    Dim C As Range

    For Each C In MyRng

        If C.Font.Bold = True Then

            SUMBOLD = SUMBOLD + C.Value

        End If

    Next C

    End Function

__________________

و طريقة عمل الدالة
لو كان عندنا قيم موجودة في المدى من
A1:A10
ستكون المعادلة

=SUMBOLD(A1:A10)

__________________

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

BOLD

نفس الكود السابق مع بعض التعديلات البسيطة كالتالي :

Function COUNTBOLD(MyRng As Range) As Long
Application.Volatile
Dim C As Range
For Each C In MyRng
    If C.Font.Bold = True Then
        COUNTBOLD = COUNTBOLD + 1
    End If
Next C
End Function

__________________

و تكون الدالة :

=COUNTBOLD(A1:A10)

__________________

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

BOLD

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

BOLD

فيكون ذلك بإستبدال

TRUE

في الكود أعلاه بـ

FALSE

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

دمتم في حفظ الله

Image

كود لنسخ الأصناف إلى صفحاتها

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

فكرة الكود تقوم على التالي:
1.     يوجد لدينا حركات أصناف في الصفحة الرئيسية و هي صفحة الحركات و اسمهاTotal و اسماء الاصناف موجودة في العمود A
2.     و يوجد عدد من الاصناف من ضمنها صنف اسمهOrange و له أيضاً صفحة اسمها Orange .
3.     و صنف آخر اسمهApple و له أيضاً صفحة بنفس الإسم
4.     و نريد كود يقوم بعملcut لاسم الصنف و من ثم Paste في الصفحة المرتبطة بإسمه .
و لعمل ذلك قدمت الكود التالي:

 Sub Excel4Us()

 Dim c As Range, LR As Integer, Rng As Range
 Application.EnableEvents = False
 LR = Sheets("Total").Range("a" & Rows.Count).End(xlUp).Row
 Set Rng = Sheets("Total").Range("a2:a" & LR)
 For Each c In Rng
     Select Case c.Value
         Case Is = "Apple"
            c.EntireRow.Cut Sheets("apple").Range("a" & Sheets("apple").Range("a" & Rows.Count).End(xlUp).Row + 1)
         Case Is = "Orange"
            c.EntireRow.Cut Sheets("Orange").Range("a" & Sheets("Orange").Range("a" & Rows.Count).End(xlUp).Row + 1)
     End Select
 Next c
 Rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 Application.EnableEvents = True
 End Sub

__________________

و لكن عند تطبيقه

سنلاحظ البطئ في حركات القص و اللصق

و لذلك قمت بعمل كود اخر رديف له

و هو سريع بإستخدام خاصية الفلترة

و كان هذا هو الكود :

 Sub Excel4Us()
 Dim c As Range, LR As Integer, Rng As Range, Product()
 Application.EnableEvents = False
 LR = Sheets("Total").Range("a" & Rows.Count).End(xlUp).Row
 Set Rng = Sheets("Total").Range("a2:d" & LR)
 Product = Array("Apple", "Orange")
 Range("A1:D1").AutoFilter
 With Rng
     For i = LBound(Product) To UBound(Product)

Image

إضافة قائمة منسدلة بأسماء الصفحات و التنقل بينها

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

طلب مني أحد الأخوة عمل قائمة منسدلة بأسماء الصفحات و عند إختيار إسم الصفحة من القائمة المنسدلة أن يتم تفعيل تلك الصفحة, و لعمل ذلك في حدث فتح الصفحة إستخدمنا الكود التالي :

Dim ws As Worksheet For Each ws In Sheets Range("M" & ws.Index).Value = ws.Name Next ws Columns("M:M").NumberFormat = ";;;" LR = Sheets("Master").Range("m" & Rows.Count).End(xlUp).Row With Range("B2").Validation .Delete .Add xlValidateList, Formula1:="=M2:M" & LR End With End Sub

حيث سيقوم الكود السابق بإضافة أسماء الصفحات و من ثم إضافتها للقائمة المنسدلة
و أضفت الكود التالي ليتم الإنتقال إلى الصفحة المعنية بمجرد إختيارها من القائمة المنسدلة :

Private Sub Worksheet_Change(ByVal Target As Range) If Range("b2").Value = "" Then Exit Sub If Target.Address(False, False) <> "B2" Then Exit Sub Sheets(Range("b2").Value).Select End Sub