المشروع الكبير (مكتبة الصرح .. زاخرة بالشرح) وهي عبارة عن تجميع لمكتبة الأكواد

[ibn_egypt]

حاولت بكلا الطريقتين و اعطاني 

FindWindow Missmatch error

 

أخى الفاضل

 

ما هو اصدار الويندوز لديك وما هو اصدار الأوفيس ؟؟؟؟

 

تحياتي  

[ابو تراب]

اكواد التعامل مع التعليقات او Comments

 

للتوضيح اكثر ارفق مثال

 

Sub btnA1Comment()
Dim cmt As Comment


' عين مرجع للكائن تعليق للخلية
Set cmt = [A1].Comment


' اذا كان لا يوجد تعليق للخلية ..اضف تعليق
If cmt Is Nothing Then
' اضف تعليق و عين المرجع
    Set cmt = [A1].AddComment
    cmt.Text Text:="هذا تعليق في الخلية A1" & vbCrLf & vbCrLf & "تعليق في سطر جديد"
End If
End Sub


Sub btnA1EditComment()
Dim cmt As Comment


' عين مرجع للكائن تعليق للخلية
Set cmt = [A1].Comment


' اذا كان لا يوجد تعليق للخلية ..اضف تعليق
If Not cmt Is Nothing Then
'افتح التعليق في وضع التحرير
    [A1].Select
    SendKeys "+{F2}"
End If


End Sub


Sub btnDeleteA1Comment()
Dim cmt As Comment


' عين مرجع للكائن تعليق للخلية
Set cmt = [A1].Comment


' اذا كان لا يوجد تعليق للخلية ..اضف تعليق
If Not cmt Is Nothing Then
' احذف التعليق
    cmt.Delete
End If
End Sub






Sub btnHideAllComments()
Dim cmt As Comment


For Each cmt In ActiveSheet.Comments
    cmt.Visible = False
Next
End Sub


Sub btnDeleteAllComments()
Dim cmt As Comment


For Each cmt In ActiveSheet.Comments
    cmt.Delete
Next
End Sub


Sub btnA2Comment()
Dim cmt As Comment


' عين مرجع للكائن تعليق للخلية
Set cmt = [A2].Comment


' اذا كان لا يوجد تعليق للخلية ..اضف تعليق
If cmt Is Nothing Then
' اضف تعليق و عين المرجع
    Set cmt = [A2].AddComment
    cmt.Text Text:="هذا تعليق في الخلية A2"
End If


' اظهر التعليق و اختاره
cmt.Visible = True
cmt.Shape.Select
End Sub


Sub btnA3Comment()
Dim cmt As Comment


' عين مرجع للكائن تعليق للخلية
Set cmt = [A3].Comment


' اذا كان لا يوجد تعليق للخلية ..اضف تعليق
If cmt Is Nothing Then
' اضف تعليق و عين المرجع
    Set cmt = [A3].AddComment
    cmt.Text Text:="تحذير" & vbCrLf & "هذا تعليق في الخلية A3"
    ' تنسيق التعليق
    With cmt.Shape.TextFrame
    ' تنسيق الخط
      .Characters.Font.Name = "Times New Roman"
      .Characters.Font.Size = 11
      .Characters.Font.Bold = False
      .Characters.Font.ColorIndex = 0
    'تلوين السطر الاول من التعليق
       .Characters(1, 5).Font.Color = vbRed
       .Characters(1, 5).Font.Bold = True
    End With
End If
End Sub


Sub btnCPI()
Dim cmt As Comment


' عين مرجع للكائن تعليق للخلية
Set cmt = [A4].Comment


If cmt Is Nothing Then


Set cmt = [A4].AddComment
With cmt
    .Text Text:=""
    ' اضافة صورة
    .Shape.Fill.UserPicture ThisWorkbook.Path & "\CPI.jpg"
    .Visible = False
End With
End If


End Sub

 

Comments.zip

[ابو تراب]

كود لعرض الاسم كاملا لمستخدم الويندوز الحالي

 

مرفق مثال

Sub btnGetFullUserName()
Dim Accounts As Object, User As Object
Dim ComputerName As String

' الجهاز الحالي
ComputerName = "."

' احصل على مرجع لحسابات الويندوز
Set Accounts = GetObject("WinNT://" & ComputerName & "")

' فلتر الحسابات حسب الاسماء
Accounts.Filter = Array("user")

' افحص جميع الاسماء
For Each User In Accounts
' تأكد ان المستخدم هو المستخدم الحالي للنظام
    If User.Name = Environ("Username") Then
    ' اعرض الاسم كاملا اذا وجد
        MsgBox "مرحبا " & User.FullName, vbInformation + vbMsgBoxRtlReading
    End If
Next
End Sub

Get Full user name.zip

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

أخي الحبيب أبو تراب جربت الكود الأخير الخاص بعرض الاسم كاملاً ولم يظهر لي الاسم فقط رسالة مرحباً..

حاولت البحث عن بديل .. كل الأكواد المشابهة لا تعمل معي .. ترى ما السبب؟

[ابو تراب]

تقبل شكري على اهتمامك الكريم بالكود

 

اغلب الظن انه لم يتم تعيين قيمة لل Full name او Display Name

 

في الصورة ادناه 

 

اسم الحساب هو Family بينما الاسم الكامل هو Sweet Heart

 

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

 

ارجوا ان ينجح هذه المرة

 

Sub btnGetFullUserName()
Dim Accounts As Object, User As Object
Dim ComputerName As String
Dim UserName As String
' الجهاز الحالي
ComputerName = "."


' احصل على مرجع لحسابات الويندوز
Set Accounts = GetObject("WinNT://" & ComputerName & "")


' فلتر الحسابات الى الاسماء
Accounts.Filter = Array("user")


' افحص جميع الاسماء
For Each User In Accounts
' تأكد ان المستخدم هو المستخدم الحالي للنظام
    If User.Name = Environ("Username") Then
    ' اعرض الاسم كاملا اذا وجد
        UserName = User.FullName
        If UserName = "" Then UserName = User.Name
        MsgBox "مرحبا " & UserName, vbInformation + vbMsgBoxRtlReading
    End If
Next
End Sub

تقبل تحيايتي 

 

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

بارك الله فيك أخي الحبيب أبو تراب فقد أثريت المكتبة بشكل هائل ومفيد جدا
تمت إضافة الكود الأخير بحمد الله

واعذرني لأنني لا أضيف للمكتبة كود إلا بعد تجربته وتأكدي من أنه يعمل تماماً..

وجزيت خيراً على الإيضاح الرائع

تقبل تحياتي القلبية ... ولا حرمنا الله من إبداعاتك المتميزة

[ابو تراب]

كود لنسخ ملف الاكسل كل 30 يوما و يتم تخزين الملف الجديد في المجلد Monthly Reports مع تاريخ الانشاء و اللوقت

 

عملت مثال لتتضح الطريقة

 

كل ماعليك فعله هو وضع الاجراء CheckAndCopyThisWB في حدث فتح الملف

 

Sub CheckAndCopyThisWB()
' المجلد الذي سيتم تخزين الملفات فيه
Const DestDir As String = "\Monthly Reports\"
' عنوان الخلية التي تحتوي على اخر تاريخ تم نسخ الملف
Const LastCopyCell As String = "B1"
' اسم الملف بدون امتداد
Dim WBName As String
' امتداد الملف بدون الاسم
Dim WBExtension As String
' المسار كاملا لملف المصدر
Dim SourceFile As String
' المسار كاملا للملف الجديد
Dim DestFile As String


' تأكد انه مرة 30 يوما على اخر عملية نسخ او ان الملف ينسخ للمرة الاولى
If Sheets("LOG").Range(LastCopyCell).Value = "" Or DateAdd("d", 1, Sheets("LOG").Range(LastCopyCell).Value) <= Date Then


    WBName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - (Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, ".") + 1))
    WBExtension = Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, "."), 7)
    SourceFile = """" & ThisWorkbook.FullName & """"
    DestFile = """" & ThisWorkbook.Path & DestDir & WBName & Format(Now(), "dd-mmm-yy-h-mm;@") & WBExtension & """"
    ' انسخ الملف
    Shell "CMD /C COPY /-Y " & SourceFile & " " & DestFile, vbHide
    ' حدث تاريخ اخر عملية نسخ
    Sheets("LOG").Range(LastCopyCell).Value = Date
End If


End Sub

 

Check and Copy Workbook.zip

[Yasser Fathi Albanna]

كود إخفاء المعادلات داخل الشيت ومنع حذفها

يوضع داخل ThisWorkbook

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

Dim formula As Range

On Error Resume Next

   Sh.Unprotect Password:="password"

   With Selection

   .Locked = False

   .FormulaHidden = False

End With

If Target.Cells.Count = 1 Then

If Target.HasFormula Then

   With Target

   .Locked = True

   .FormulaHidden = True

End With

   Sh.Protect Password:="password", UserInterFaceOnly:=True

End If

   ElseIf Target.Cells.Count > 1 Then

   Set formula = Selection.SpecialCells(xlCellTypeFormulas)

   If Not formula Is Nothing Then

   With Selection.SpecialCells(xlCellTypeFormulas)

   .Locked = True

   .FormulaHidden = True

End With

   Sh.Protect Password:="password", UserInterFaceOnly:=True

End If

End If

   On Error GoTo 0

End Sub

[Yasser Fathi Albanna]

كود حماية جميع أوراق العمل مرة واحدة

يوضع هذا الكود فى موديول

Protect All Worksheets at Once

Sub Protect_All()

For i = 1 To Sheets.Count
Sheets(i).Protect
Next i

End Sub

كود لإلغاء الحماية

Unprotect All Worksheets at Once

Sub Unprotect_All()
For i = 1 To Sheets.Count
Sheets(i).Unprotect
Next i
End Sub

[Yasser Fathi Albanna]

كود حذف الصفوف المكررة فى العمود

يوضع الكود داخل موديول

Public Sub DeleteDuplicateRows()

' This macro will delete all duplicate rows which reside under
‘the first occurrence of the row.
‘
‘Use the macro by selecting a column to check for duplicates
‘and then run the macro and all duplicates will be deleted, leaving
‘the first occurrence only.

Dim R As Long
Dim N As Long
Dim V As Variant
Dim Rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Rng = Application.Intersect(ActiveSheet.UsedRange, _
                    ActiveSheet.Columns(ActiveCell.Column))
Application.StatusBar = "Processing Row: " & Format(Rng.Row, "#,##0")
N = 0
For R = Rng.Rows.Count To 2 Step -1
If R Mod 500 = 0 Then
    Application.StatusBar = "Processing Row: " & Format(R, "#,##0")
End If

V = Rng.Cells(R, 1).Value

If V = vbNullString Then
    If Application.WorksheetFunction.CountIf(Rng.Columns(1), vbNullString) > 1 Then
        Rng.Rows(R).EntireRow.Delete
        N = N + 1
    End If
Else
    If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
        Rng.Rows(R).EntireRow.Delete
        N = N + 1
    End If
End If
Next R

EndMacro:

Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(N)
End Sub

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

أخي الفاضل ياسر البنا

جزيت خيرا على الأكواد التي تقدمها .. ولكن هل لي بسؤال هل تقوم بتجربة الأكواد قبل وضعها ؟؟

أنا جربت كود إخفاء المعادلات داخل الشيت ومنع حذفها ولم يعمل معي ..

بالنسبة للكود الخاص بحماية كل أوراق العمل والغاء الحماية كود مكرر تمت مشاركته من قبل ..

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

[KHMB]

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

الاخ ياسر البناء يا اخي اخونا ياسر  خليل إستحى وهو يكرر عليك الملاحظة

1- كل ماترسله نسخ من نفس الموقع ولصق وهذا مايمنع لاي كود قصير ومفيد فقط لتسهيل الرجوع اليها لان كل الاكواد اللي ارسلتها موجودة ومكررة في المنتدى

2- لا شرح ولا مثال ولا فرامل هذا وانت مسمي نفسك مهندس اجل كيف لو لم تكن مهندس بتسدح المنتدى

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

ممكن توصل تسعمائة مشاركة وانت لازلت عضو فقط ممكن تزيد لك نجمة او اثنين لكن لاحظ البعض 150 - 200 مشاركة وهو خبير وبعدها ممكن مشرف ليه لان الادارة تعتمد علي اشياء اخرى في التقييم

بالله كم مره ارجع وعدًها وشوف كم مره والاخ ياسر يكرر ويكرر عليك ويوضح لك وانت لاحياة لمن تنادي هذا وانت مسماك بالتعريف مهندس.

هون علي الراجل شويه الإلتزام سلوك طيب

بارك الله فيك

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

أخي خالد

بارك الله فيك وجزاك الله كل خير

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

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

أسأل الله العلي القدير أن يجمعنا في الفردوس الأعلى في مستقر رحمته وأن يديم بيننا الحب والمودة والرحمة التي ندرت في زماننا هذا

تقبلوا تحياتي

[ابو تراب]

تعديل في الكود 

 

 

كود لفتح مجلد

 

مثال:

 

اذا افترضنا ان المدى من A1 الى A5 يحتوي على اسماء المجلدات في المسار في المسار C:\test

 

فلفتح المجلد المعني بمجرد اختيار خلية من خلاياء المدى اعلاه .. نكتب الكود التالي في حدث الصفحة:

 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' تأكد ان  الخلية تقع على المدى المطلوب و ان الخلية لديها قيمة
    If Not Intersect(Target, Range("A1:A5")) Is Nothing And Target.Count() = 1 Then
        If Target.Value <> "" Then Shell "cmd /c start C:\Test\" & Target.Value, vbHide
    End If


End Sub

 

في حالة ان المسار الملف او المجلد يحتوي على فراغات فان الامر START لن ينفذ و ذلك لانه يعتبر الوسيط الاول عنوان النافذة الجديدة

 

على كلا هذا الكود في حالة وجود فراغات او عدم وجودها

Shell "CMD /C START """" ""F:\Monthly Report\Jan 2015.pdf""", vbHide

[abdoullah]

_{^{جزاك الله الجنة على هذه الأكواد وعمل جدا رااااااااااااااائع ومفيد وفقك الله}}

[Yasser Fathi Albanna]

أخى الفاضل KHMB

مع إحترامى الكبير لكلامك

إلا أننى عندى تعليق على كلامك

فى البداية أنا من محبى هذا المنتدى العظيم

وأنا لم أقوم بالبحث داخل المنتدى ونسخ الأكواد التى أشارك بها مرة أخرى بل أنا من محبى البحث داخل المواقع الأجنبية عن أكواد VBA إكسيل مفيدة أحببت أن أشارك الأستاذ الفاضل / ياسر خليل هذا العمل العظيم ليستفاد منه جميع

أعضاء هذا المنتدى العظيم الذى أكن له كل التقدير والإحترام فأنا ضمن الأشخاص الذين إستفادوا كثيرا من هذا المنتدى العظيم

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

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

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

ولو الأستاذ / ياسر شايف إن مشاركتى غير مفيدة يقول لى وانا مش هازعل

شكرا يأ أخى KHMB على طريقة ردك الغير مرضية بالنسبة لى

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

[اسامةمحمد]

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

وجعله الله في ميزان حسناتك انت وكل من شارك ولو بكود رسالة

تم تعديل يناير 13, 2015 بواسطه live8523

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

إخواني الكرام ..

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

بارك الله فيكم ، رجاء لا داعي للمشاحنات فيما بيننا ..

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

.. وبعدين ممكن أقول حاجة للباشمهندس ياسر البنا .. أنا ممتن لك بما تقدمه ، فهو بالفعل قيم للغاية ، ولكن أكرر عليك حاول أن تأتي بشروح ولو باللغة الإنجليزية وأنا أقوم بترجمتها حتى نستفيد بالفعل منها ، هذا كل ما أطلبه ..

تقبلوا تحياتي القلبية :fff:

[ibn_egypt]

استاذي القدير أ.ياسر

 

في انتظار الاصدار الجديد من المكتبة ....

 

 تحياتي  

[Yasser Fathi Albanna]

أستاذ / ياسر كل الشكر والتقدير والإحترام لحضرتك

هذا كود خاص بمنع طباعة أى ورقة

Private Sub workbook_BeforePrint(Cancel As Boolean)
	Cancel = True
	MsgBox "عفوا, لايمكنك الطباعة في هذاالملف", vbInformation
End Sub

تم تعديل يناير 13, 2015 بواسطه Eng : Yasser Fathi Albanna

[Yasser Fathi Albanna]

وهذا كود منع إضافة شيت جديد وتمت تجربته

Private Sub Workbook_NewSheet(ByVal Sh As Object)
	Application.DisplayAlerts = False
	MsgBox "عفوا, لايمكنك اضافة اوراق اخرى", vbInformation
	Sh.Delete
	Application.DisplayAlerts = True
End Sub

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

أخي الحبيب ابن مصر الغالي .. لن يتم تنزيل الإصدار الجديد إلا بعد 5 أكواد منك على الأقل

الأخ الحبيب ياسر .. يرجى البحث داخل المكتبة أولا .. قم بالبحث عن كلمة [منع] .. تقبلوا تحياتي

[Yasser Fathi Albanna]

وهذا كود لعمل تجميد الألواح داخل نافذة ورقة العمل النشطة

Sub hiarab80()
	ActiveWindow.FreezePanes = True
End Sub

[ibn_egypt]

أخي الحبيب ابن مصر الغالي .. لن يتم تنزيل الإصدار الجديد إلا بعد 5 أكواد منك على الأقل

 

 

 ما انا عاوز الاصدار الجديد علشان اقيم الوضع واشوف الدنيا فيها ايه 

 

ايه اللى تمت اضافته وايه اللى لسه

 

تحياتى  

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

اسألني وأنا أجاوبك يا غالي ...

هات ما عندك !! ياما في الجراب يا غالي