فصل القيم النصية والرقمية Split Text & Number

بسم الله الرحمن الرحيم

اقدم لكم دالة معرفة لفصل القيم النصية عن القيم الرقمية

كل ما علينا هو ان نضيف هذ الكود للدالة المعرفة بموديل كما بالصورة

كود الدالة

 Public Function SplitText(WorkRng As Range, Number As Boolean) As String  
   Dim xLen As Long  
   Dim xStr As String  
   xLen = VBA.Len(WorkRng.Value)  
   For i = 1 To xLen  
     xStr = VBA.Mid(WorkRng.Value, i, 1)  
     If ((VBA.IsNumeric(xStr) And Number) Or (Not (VBA.IsNumeric(xStr)) And Not (Number))) Then  
       SplitText = SplitText + xStr  
     End If  
   Next  
 End Function  

طريقة كتابة الدالة


للقيم النصية
  =SplitText($A2;0)
 أو
=SplitText($A2;False)

للقيم الرقمية
=SplitText($A2;1)
أو
=SplitText($A2;TRUE)

كود اخر لفصل كل قيمة على حدا

الكود المستخدم للقيمتين

 Sub split_Text()  
   Dim xLen As Long  
   Dim xStr As String  
   Dim Rng As Range  
   For Each Rng In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)  
     xLen = VBA.Len(Rng.Value)  
     Rng.Offset(, 4).ClearContents  
     For i = 1 To xLen  
       xStr = VBA.Mid(Rng.Value, i, 1)  
       If Not (VBA.IsNumeric(xStr)) And Not (Number) Then  
         Rng.Offset(, 4) = Rng.Offset(, 4) + xStr  
       End If  
     Next i  
   Next Rng  
 End Sub  
 Sub Split_NUM()  
   Dim xLen As Long  
   Dim xStr As String  
   Dim Rng As Range  
   For Each Rng In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)  
     xLen = VBA.Len(Rng.Value)  
     Rng.Offset(, 5).ClearContents  
     For i = 1 To xLen  
       xStr = VBA.Mid(Rng.Value, i, 1)  
       If (VBA.IsNumeric(xStr)) And Not (Number) Then  
         Rng.Offset(, 5) = Rng.Offset(, 5) & xStr  
       End If  
     Next i  
   Next Rng  
 End Sub
  

لتحميل الملف اضغط هنا

ياسر العربي

عرض صورة المنتج ومعلوماته داخل اليوزر فورم

بسم الله الرحمن الرحيم

سابقا كنت تبحث عن طريقة تعرض بها منتجا علي الاكسيل بمعلومات 

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

 بمعادلات بسيطة وسهلة اما صورة المنتج فكانت هذه هي مشكلة بعض 

المستخدمين . فيفقد الملف جزء مهم وهو الصورة التوضيحية للمنتج

فاحببت ان افيدكم بكود كنت قد نشرته منذ فترة واعدت نشره مره اخرى

لان المعظم سيحتاجه لاكثر من استخدام

اليكم صورة  المثال 

لتحميل الملف اضغط هنا

اعداد / ياسر العربي

بحث متقدم - سرعة عالية ومرونة باستخدام المصفوفات

بسم الله الرحمن الرحيم 

بحث متقدم

كود بحث متقدم  يفوق معظم أنواع  البحث بالاعتماد على المصفوفات 

لضمان كفاءة عالية للبحث وسرعة جلب البيانات 

والمرونة العالية به  من حيث البحث داخل كل الأعمدة الموجودة داخل النطاق 

تم توضيح المتغيرات التي تستطيعوا تعديلها لتتوافق مع ملفاتكم 

الكود المستخدم داخل الملف 

 Sub Yasser_Serch()  
   Dim myArray, lr, X, targt, targtN  
   Dim SERCH As Worksheet, DATA As Worksheet  
   '____________________________________________  
   Set DATA = Worksheets("Sheet2")  'اسم شيت قاعدة البيانات  
   Set SERCH = Worksheets("Sheet1")  'اسم الشيت الخاص بالبحث  
   '____________________________________________  
   lr = DATA.Cells(Rows.Count, 1).End(xlUp).Row  'اخر صف به بيانات  
   SERCH.Range("A4:J" & SERCH.Cells(Rows.Count, 4).End(xlUp).Row + 1).ClearContents  'مسح نطاق البحث القديم  
   targt = SERCH.Range("e1").Value  'خلية البحث  
   targtN = Application.WorksheetFunction.Match(SERCH.Range("D1"), SERCH.Range("A3:J3"), 0)  'دالة لايجاد رقم عمود البحث  
   myArray = DATA.Range("A2:J" & lr + 1)  'نطاق قاعدةالبيانات الذي سيتم البحث فيه  
   '____________________________________________  
   ReDim Y(1 To lr, 1 To 10)  
   For X = 1 To lr  
     If targt = "" Then Exit Sub  
     If myArray(X, targtN) Like targt & "*" Then  
       rw = rw + 1  
       Y(rw, 1) = myArray(X, 1): Y(rw, 6) = myArray(X, 6)  
       Y(rw, 2) = myArray(X, 2): Y(rw, 7) = myArray(X, 7)  
       Y(rw, 3) = myArray(X, 3): Y(rw, 8) = myArray(X, 8)  
       Y(rw, 4) = myArray(X, 4): Y(rw, 9) = myArray(X, 9)  
       Y(rw, 5) = myArray(X, 5): Y(rw, 10) = myArray(X, 10)  
     End If  
   Next X  
   If rw > 0 Then SERCH.Cells(Rows.Count, 1).End(xlUp)(2, 1).Resize(rw, 10).Value = Y()  
 End Sub  

لتحميل الملف اضغط هنا

تم عمل اضافة بسيطة للبحث بشرطين اي شرط مع شرط التاريخ

صورة توضيحية لشكل البحث

 
لتحميل الملف اضغط هنا

اعداد /  ياسر العربي

كود بحث سريع جدا

بسم الله الرحمن الرحيم

اقدم لكم اليوم كود بحث رائع وسريع جدا حتى مع كثرة البيانات

الكود يقوم بالبحث داخل الشيت 1 عن القيمة المدخلة في خلية البحث بالشيت 2

ويتم عرض النتائج داخل الشيت 2 بالعمود A

الكود المستخدم داخل الملف

 Sub Yasser_Serch()  
   Dim xx, zz, targt  
   Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents  
   targt = Range("C2").Text  
   xx = Sheet1.Range("A1:A" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row).Value  
   ReDim Y(1 To Sheet1.Range("A1:A" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row).Count ^ 2, 1 To 1)  
   For Each zz In xx  
     If targt = "" Then Exit Sub  
     If zz Like targt & "*" Then  
       rw = rw + 1  
       Y(rw, 1) = zz  
     End If  
   Next zz  
   If rw > 0 Then Sheet2.Cells(Rows.Count, 1).End(xlUp)(2, 1).Resize(rw, 1).Value = Y()  
 End Sub  

وفي حدث تغيير الشيت يتم تشغيل الكود كما موضح

 Private Sub Worksheet_Change(ByVal Target As Range)  
   If Target.Address = "$C$2" Then  
     Call Yasser_Serch  
   End If  
 End Sub  

لتحميل الملف اضغط هنا


اعداد / ياسر العربي

استخراج حالة الطالب ناجح او دور ثان ومواد الرسوب

بسم الله الرحمن الرحيم

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

وهو كود لاستخراج حالة الطالب  

ناجح او دور ثان اضافة لذلك مواد الرسوب 

الكود يحتاج الى تحديد الثوابت الموجودة بالكود  

وتم توضيح مكان التعديلات بالكود حسب توزيعات الملف 

الكود 

Sub YASSER_ELARABY()
'YASSER_ELARABY
'26-9-2016
    Dim ARR
    Dim ARRY
    Dim ARRYS
    Dim ALL_LESS As String
    Const STATUS As Byte = 101    'عمود الحالة ناجح او دور ثان
    Const NOTES As Byte = 102  ' عمود الملاحظات عمود المواد او منقول للصف ا لاخر
    Const GENDER As Byte = 112  ' عمود الجنس ذكر او انثى
    '_____________________________________________________
    Const LESS_ROW As Byte = 6  'صف الدرجة الصغرى
    Const NAM_ROW As Byte = 2    'صف اسماء المواد
    Const NAME_FIRST As Byte = 7  ' اول صف لاسماء الطلاب
    Const NAME_LAST As Long = 206 + NAME_FIRST  ' عدد الطلاب
    '_____________________________________________________
    ARR = Array(9, 18, 27, 36, 46, 52, 54, 59, 64, 69, 78)  ' اعمدة اختبار الفصل الدارسي الثاني  لجميع المواد
    ARRY = Array(13, 22, 31, 40, 51, 52, 57, 62, 67, 72, 82)  'اعمدة الدرجة النهائية لجميع المواد
    ARRYS = Array(5, 14, 23, 32, 41, 52, 53, 58, 63, 68, 74)  'اعمدة اسماء كل المواد
    '_____________________________________________________
    With Sheet2 'اسم الشيت الموجود به البيانات
    For R = NAME_FIRST To NAME_LAST
        For X = 0 To UBound(ARR)
            On Error Resume Next
            Application.ScreenUpdating = False
            If ARR(X) = 46 Then
                If Val(.Cells(R, ARR(X))) + Val(.Cells(R, ARR(X) + 1)) < Val(.Cells(LESS_ROW, ARR(X))) Or .Cells(R, ARR(X)) = "غ" Or .Cells(R, ARR(X) + 1) = "غ" Then
                    ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " - "
                    GoTo 86
                Else
                    GoTo 86
                End If
            End If
            If .Cells(R, ARR(X)) < .Cells(LESS_ROW, ARR(X)) Or .Cells(R, ARR(X)) = "غ" _
               Or .Cells(R, ARRY(X)) < .Cells(LESS_ROW, ARRY(X)) Or .Cells(R, ARRY(X)) = "غ" Then
                ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " - "
            End If
86      Next X
        '_____________________________________________________

        If ALL_LESS = "" Then
            If .Cells(R, GENDER) = 1 Then .Cells(R, STATUS) = "ناجح "
            If .Cells(R, GENDER) = 2 Then .Cells(R, STATUS) = "ناجحة "
            If .Cells(R, GENDER) = 1 Then .Cells(R, 102) = "ومنقول " & INFO.Range("B14")
            If .Cells(R, GENDER) = 2 Then .Cells(R, 102) = "ومنقولة " & INFO.Range("B14")
        ElseIf ALL_LESS <> "" Then
            If .Cells(R, GENDER) = 1 Then .Cells(R, STATUS) = "له دور ثان في"
            If .Cells(R, GENDER) = 2 Then .Cells(R, STATUS) = "لها دور ثان في"
            .Cells(R, 102) = Left(ALL_LESS, Len(ALL_LESS) - 2)
            ALL_LESS = Empty
        End If
    Next R
    End With
    Application.ScreenUpdating = True
End Sub

كما هو موضح اماكن التعديل بالكود

لتحميل الملف اضغط هنا

تعديل اخر للكود ليتماشى مع نظام المدارس اكثر 

التعديل يشمل الرسوب باقل من ثلث الدرجة للفصل الدراسي الثاني 

واذا تغيب الطالب في كل المواد او مجموع كل المواد صفر يصبح الطالب غائب 

الكود

 Sub YASSER_ELARABY()  
 'YASSER_ELARABY  
   Dim ARR  
   Dim ARRY  
   Dim ARRYS  
   '___________________________________________  
   Dim R As Long  
   Dim X As Long  
   Dim XX As Byte  
   Dim ALL_LESS As String  
   '___________________________________________  
   Const STATUS As Byte = 101  'عمود الحالة ناجح او دور ثان  
   Const NOTES As Byte = 102 ' عمود الملاحظات عمود المواد او منقول للصف ا لاخر  
   Const GENDER As Byte = 112 ' عمود الجنس ذكر او انثى  
   '_____________________________________________________  
   Const LESS_ROW As Byte = 6 'صف الدرجة الصغرى  
   Const NAM_ROW As Byte = 2  'صف اسماء المواد  
   Const NAME_FIRST As Byte = 7 ' اول صف لاسماء الطلاب  
   Const NAME_LAST As Long = 206 + NAME_FIRST ' عدد الطلاب  
   '_____________________________________________________  
   ARR = Array(9, 18, 27, 36, 46, 52, 54, 59, 64, 69, 78) ' اعمدة اختبار الفصل الدارسي الثاني لجميع المواد  
   ARRY = Array(13, 22, 31, 40, 51, 52, 57, 62, 67, 72, 82) 'اعمدة الدرجة النهائية لجميع المواد  
   ARRYS = Array(5, 14, 23, 32, 41, 52, 53, 58, 63, 68, 74) 'اعمدة اسماء كل المواد  
   '_____________________________________________________  
   With Sheet2  'اسم شيت البيانات  
     Application.ScreenUpdating = False  'الغاء تحديث الشاشة  
     Application.Calculation = xlManual  ' ايقاف الحساب التلقائي  
     For R = NAME_FIRST To NAME_LAST  ' حلقة تكرارية تبدأ بأول اسم طالب الى اخر اسم  
       For X = 0 To UBound(ARR)  ' حلقة تكرارية تبدأ من الصفر الى اقصى مصفوفة اعمدة اختبار الفصل الدارسي الثاني  
         On Error Resume Next  
         '____________________________________________________  
         'يتم حساب عدد ا لمواد المتغيب بها الطالب او درجتها صفر ويتم وضع عدد المواد في المتغير اكس اكس  
         'اذا وصل عدد المواد الى 11 اصبح الطالب متغيب  
         If .Cells(R, ARRY(X)) = 0 Or .Cells(R, ARRY(X)) = "غ" Then  
           XX = XX + 1  
         End If  
         '____________________________________________________  
         'هذا الجزء خاص بمادة العلوم تحديدا الفصل الدراسي الثاني لانه مقسم على عمودين فتم اضافة هذا الجزء ليتم معالجة هذه المرحلة  
         If ARR(X) = 46 Then  
           'لايوجد اختلاف بين هذا الكود وبين الكود الموجود بالاسفل  
           If Val(.Cells(R, ARR(X))) + Val(.Cells(R, ARR(X) + 1)) < Val(.Cells(LESS_ROW, ARR(X))) Or .Cells(R, ARR(X)) = "غ" Or .Cells(R, ARR(X) + 1) = "غ" Then  
             ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " لثلث الدرجة " & " - ": GoTo 86  
             GoTo 86 'هنا يتم تخطى عمل الكود بالاسفل حتى لايتم معالجة مادة العلوم مرة اخرى  
           Else  
             GoTo 86 'وهنا ايضا يتم تخطى مادة العلوم الى المادة الاخرى  
           End If  
         End If  
         'هنا يتم مقارنة المواد بالدرجة الصغرى الخاصة الفصل الدارسي الثاني في اول الكود او اذا كانت غياب يتم اضافة اسم المادة من صف المواد الى المتغير  
         'ALL_LESS  
         'او مقارنة الدرجة النهائية لكل مادة بالدرجة الصغرى لها او اذا كانت غياب اذا تحقق الشرط فيتم اضافة المادة الى المتغير  
         'ALL_LESS  
         '______________________________________________________  
         If .Cells(R, ARR(X)) < .Cells(LESS_ROW, ARR(X)) Or .Cells(R, ARR(X)) = "غ" Then  
           ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " لثلث الدرجة " & " - ": GoTo 86  
         End If  
         If .Cells(R, ARRY(X)) < .Cells(LESS_ROW, ARRY(X)) Or .Cells(R, ARRY(X)) = "غ" Then  
           ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " - "  
         End If  
         '______________________________________________________  
 86     Next X  'الذهاب الى المادة الاخرى لاعادة تطبيق الكود مرة اخرى حتى انتهاء جميع المواد  
       'اذا كان المتغير اكس اكس بيساوي عدد المواد اذن الطالب متغيب  
       If XX = 11 Then ALL_LESS = "غياب ": XX = 0  
       '_____________________________________________________  
       'هنا بعد اكتمال الكود يتم عمل شرط للمتغير  
       'ALL_LESS  
       'اذا كان المتغير فارغ اي لم يتم اضافة اي مواد به اذا الطالب ناجح  
       If ALL_LESS = "" Then  
         If .Cells(R, GENDER) = 1 Then .Cells(R, STATUS) = "ناجح "  'اذا كان نوع الطالب ذكر يتم وضع ناجح  
         If .Cells(R, GENDER) = 2 Then .Cells(R, STATUS) = "ناجحة "  'اذا كانت انثى يتم وضع ناجحه  
         If .Cells(R, GENDER) = 1 Then .Cells(R, NOTES) = "ومنقول " & INFO.Range("B14")  'ويتم وضع في الملاحظات منقول الى ويتم جلب الصف من صفحة الانفو  
         If .Cells(R, GENDER) = 2 Then .Cells(R, NOTES) = "ومنقولة " & INFO.Range("B14")  'مثل ماسبق  
         'اما اذا كان المتغير يحمل اي بيانات لمواد يصبح الطالب له دور ثان  
       ElseIf ALL_LESS <> "" Then  
         If .Cells(R, GENDER) = 1 Then .Cells(R, STATUS) = "له دور ثان في"  'مثل ما سبق بخصوص النوع  
         If .Cells(R, GENDER) = 2 Then .Cells(R, STATUS) = "لها دور ثان في"  '  
         .Cells(R, NOTES) = Left(ALL_LESS, Len(ALL_LESS) - 2)  'هنا يتم وضع قيمة المتغير اي المواد في خلية الملاحظات  
         ALL_LESS = Empty  'تفريغ المتغير لاعادة تعبئة اسم طالب اخر  
       End If  
       '_____________________________________________________  
     Next R  'الذهاب الى الصف التالي حتى انتهاء عدد الطلاب  
   End With  
   Application.ScreenUpdating = True  'اعادة تحديث الشاشة  
   Application.Calculation = xlAutomatic  'تشغيل الحساب التلقائي  
 End Sub  

لتحميل الملف اضغط هنا

اعداد / ياسر العربي

انتحار جماعي لكل ملفات الاكسيل في مسار معين حسب شرط معين

بسم الله الرحمن الرحيم

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

ثانيا

نضع لكم كود لحذف جميع ملفات الاكسيل من مسار معين عند فتح ملف اكسيل وتحقق الشرط المحدد

الكود في حدث فتح المصنف

 Sub Clear_All_Files_And_SubFolders_In_Folder()  
 Dim FSO As Object  
 Dim MyPath As String  
 If Date > DateValue("15/9/2016") Then  
 Set FSO = CreateObject("scripting.filesystemobject")  
 MyPath = "D:\Yasser" '<<مسارالملفات والفولدرات المرادمسحهم  
 If Right(MyPath, 1) = "\" Then  
 MyPath = Left(MyPath, Len(MyPath) - 1)  
 End If  
 If FSO.FolderExists(MyPath) = False Then  
 'MsgBox MyPath & " doesn't exist"  
 Exit Sub  
 End If  
 On Error Resume Next  
 FSO.deletefile MyPath & "\*.xl*", True 'مسح ملفات الاكسيل اذاكانت تريد مسح جميع الملفات ضع * بدلا من الاكسيل  
 ' FSO.deletefolder MyPath & "\*.*", True' اذا كنت تريدمسح كل الفولدرات الموجودة داخل المسار المحدد  
 On Error GoTo 0  
 End If  
 End Sub 0

كل ما عليكم هو التعديل على المسارات المطلوبة

لتحميل الملف من هنا

ومن الممكن حذف اي ملفات اخرى غير الاكسيل فقط يتم تحديد امتداد الملفات بالكود 

وشكرا

انتحار ملف الإكسيل Kill Workbook From HD لابو البراء

بسم الله الرحمن الرحيم


KILL Workbook

اثراء لموضوع اخي الكريم ابو البراء قمت بتعديل الكود لمعرفة رقم الهارد الفزيكال

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

 Function GetPhysicalSerial() As Variant  
   Dim obj As Object  
   Dim WMI As Object  
   Dim SNList() As String, i As Long, Count As Long  
   Set WMI = GetObject("WinMgmts:")  
   For Each obj In WMI.InstancesOf("Win32_PhysicalMedia")  
     If obj.SerialNumber <> "" Then Count = Count + 1  
   Next  
   ReDim SNList(1 To Count, 1 To 1)  
   i = 1  
   For Each obj In WMI.InstancesOf("Win32_PhysicalMedia")  
     SNList(i, 1) = obj.SerialNumber  
     i = i + 1  
     If i > Count Then Exit For  
   Next  
   GetPhysicalSerial = SNList  
 End Function  

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

 Private Sub Workbook_Open()  
   Range("A1") = GetPhysicalSerial  
   If Range("A1") <> "31534756394a5a41304237333634202020202020" Then 'هنا نضع رقم الهارد الفيزيكال  
     With ThisWorkbook  
       .Save  
       .ChangeFileAccess Mode:=xlReadOnly  
       Kill .FullName  
       .Close SaveChanges:=False  
     End With  
   End If  
 End Sub  

لتحميل الملف من هنا

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

مع مراعاة تغيير رقم السيريال

في اول الامر نقوم بازالة اول علامة فقط ونحفظ الملف ونفتحه مرة اخرى سيظهر لنا رقم الهارد في الخلية A1

نقوم بنسخه الى الكود مكان الرقم الاخر ونقوم بازالة كل العلامات من امام الكود

وشكرا

فرز الملفات بانشاء لكل قسم فولدر ونقل الملفات لكل قسم خاص بها VBA

بسم الله الرحمن الرحيم

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

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

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

 هذه صورة البيانات بالشيت

وهذه صورة للملفات الموجودة داخل المجلد مع ملف الاكسيل

وهذه الصورة بعد تنفيذ الكود وانشاء فولدرات لكل قسم ونقل الصور لكل قسم خاص بها

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

 Sub Yasser()  
   Dim FLDR As Object  
   Dim LR As Long  
   Dim fldrname As String  
   Dim fldrpath As String  
   On Error Resume Next  
   LR = Cells(Rows.Count, 2).End(xlUp).Row  
   For X = 2 To LR  
     Set FLDR = CreateObject("scripting.filesystemobject")  
     fldrname = Range("B" & X).Text & "\"  
     fldrname2 = Range("A" & X).Text & ".BMP"  
     fldrpath = ThisWorkbook.Path & "\" & fldrname  
     If Not FLDR.folderexists(fldrpath) Then  
       FLDR.createfolder (fldrpath)  
     End If  
     FLDR.MoveFile Source:=ThisWorkbook.Path & "\" & fldrname2, Destination:=fldrpath  
   Next  
   MsgBox "تم معالجة البيانات"  
 End Sub  

لتحميل الملف اضغط هنا


اعداد / ياسر العربي

الوارد اولا صادر اولا (first in first out (FIFO

بسم الله الرحمن الرحيم

نظرا لاهتمام بعض الاخوة بموضوع الوارد اولا صادر اولا (FIFO) 

قمنا بعمل مثال بالاكواد  

لحل هذه المشكلة 

المثال يعتمد على اعمدة مساعدة ويتم مسح البيانات منها بعد الانتهاء 

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

 Sub YasserFIFO()  
   Dim z As Byte  
   'Yasserelaraby86@gmail.com  
   '+201097192367  
   Application.ScreenUpdating = False  
   Range("K6:K23").ClearContents  
   Range("D6:E23").Copy Range("R1")  
   Range("r1:s18").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp  
   Range("G6:G23").Copy Range("T1")  
   z = 1  
   For Each x In Range("g6:g23")  
     If x.Value <> "" Then  
       If x.Value <= Cells(z, 18) Then  
         Cells(x.Row, 11) = Cells(z, 19) * x.Value  
         Cells(z, 18) = Cells(z, 18) - x.Value  
       ElseIf x.Value > Cells(z, 18) Then  
 3        Cells(x.Row, 11) = Cells(x.Row, 11) + (Cells(z, 18) * Cells(z, 19))  
         x.Value = x.Value - Cells(z, 18)  
         Cells(z, 18) = 0  
         For z = 1 To 20  
           If Cells(z, 18) = 0 Then GoTo 1  
           If Cells(z, 18) > x.Value Then GoTo 2  
           If Cells(z, 18) < x.Value Then GoTo 3  
 1        Next z  
 2        Cells(x.Row, 11) = Cells(x.Row, 11) + (Cells(z, 19) * x.Value)  
         Cells(z, 18) = Cells(z, 18) - x.Value  
       End If  
     End If  
   Next  
   Range("T1:T18").Copy Range("G6:G23")  
   Range("R1:T18").Clear  
   Range("a1").Activate  
   Application.ScreenUpdating = True  
 End Sub  

لتحميل الملف اضغط هنا

اعداد / ياسر العربي

تصدير بيانات من اكسيل الى وورد Export to Word

بسم الله الرحمن الرحيم

اقدم لكم كود للتصدير الى الوورد من الاكسيل  

يتم تصدير البيانات الي ملف وورد في نفس مسار ملف الاكسيل 

كل ما عليك هو تغيير مسار الحفظ 

او تغيير النطاق المراد تصديره  

كود التصدير

 Sub Button1_Click()  
   Dim WdObj As Object, fname As String  
   fname = "Yasser"  
   Set WdObj = CreateObject("Word.Application")  
   WdObj.Visible = False  
   Range("A1:G30").Select  
   Selection.Copy  
   WdObj.Documents.Add  
   WdObj.Selection.PasteSpecial Link:=False, _  
                  DataType:=wdPasteText, Placement:= _  
                  wdInLine, DisplayAsIcon:=False  
   Application.CutCopyMode = False  
   If fname <> "" Then  
     With WdObj  
       .ChangeFileOpenDirectory "" & ThisWorkbook.Path & ""  
       .ActiveDocument.SaveAs Filename:=fname & ".doc"  
     End With  
   Else:  
     MsgBox ("File not saved, Try again.")  
   End If  
   With WdObj  
     .ActiveDocument.Close  
     .Quit  
   End With  
   Set WdObj = Nothing  
 End Sub  

___________________________________________

لتحميل المثال اضغط هنا

تحياتي

ادخال - بحث واستدعاء في ليست بوكس- تعديل - تقرير بحث - حذف

بسم الله الرحمن الرحيم

اقدم لكم اليوم برنامج لادخال البيانات والبحث عنها باي شرط بحث حسب رغبتكم وعرض  النتائج داخل ليست بوكس

ويمكنكم التعديل على اي بيان وايضا يمكنكم عرض تقرير عن اي بحث  داخل شيت مستقل

وامكانية حذف بيان غير مرغوب به من شيت البيانات

طريقة العمل كالاتي

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

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

للتعديل على صف يتم الضغط دبل كليك  علي الصف داخل الليست بوكس ليرحل الى التكست بوكس اسفل الفورم ومن ثم التعديل والضغط على تعديل

وللحذف يتم الضغط دبل كليك على الصف داخل الليست بوكس ليرحل الى التكست بوكس اسفل الفورم ومن ثم الضغط على حذف

لاستخراج نتيجة البحث  في شيت مستقل يتم الضغط علي تقرير بعد عمليه البحث ليتم ترحيل البيانات الى شيت التقرير ريبورت

صورة الفورم

الكود المستخدم داخل الملف

 Private Sub CommandButton1_Click()  
   Dim LastRow As Integer  
   Dim ii As Integer  
   With Sheets("Data")  
     LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1  
     .Cells(LastRow, 2).Value = TextBox3.Text  
     .Cells(LastRow, 3).Value = TextBox4.Text  
     .Cells(LastRow, 4).Value = TextBox5.Text  
     .Cells(LastRow, 5).Value = TextBox6.Text  
     .Cells(LastRow, 6).Value = TextBox7.Text  
     .Cells(LastRow, 7).Value = TextBox8.Text  
     .Cells(LastRow, 8).Value = TextBox9.Text  
     .Cells(LastRow, 9).Value = TextBox10.Text  
   End With  
   For ii = 2 To 10  
     Me.Controls("TextBox" & ii).Value = ""  
   Next  
 End Sub  
 Private Sub CommandButton2_Click()  
   On Error Resume Next  
   ii = 2  
   For i = 0 To Me.ListBox1.ColumnCount  
     Me.ListBox1.List(ListBox1.ListIndex, i) = Me.Controls("TextBox" & ii).Value  
     ii = ii + 1  
   Next  
   With Sheets("Data")  
     .Cells(TextBox2, 2).Value = TextBox3.Text  
     .Cells(TextBox2, 3).Value = TextBox4.Text  
     .Cells(TextBox2, 4).Value = TextBox5.Text  
     .Cells(TextBox2, 5).Value = TextBox6.Text  
     .Cells(TextBox2, 6).Value = TextBox7.Text  
     .Cells(TextBox2, 7).Value = TextBox8.Text  
     .Cells(TextBox2, 8).Value = TextBox9.Text  
     .Cells(TextBox2, 9).Value = TextBox10.Text  
   End With  
 End Sub  
 Private Sub CommandButton3_Click()  
   Sheets("Data").Rows(TextBox2).Delete Shift:=xlUp  
   On Error Resume Next  
   ii = 2  
   For i = 0 To Me.ListBox1.ColumnCount  
     Me.ListBox1.List(ListBox1.ListIndex, i) = ""  
     Me.Controls("TextBox" & ii).Value = ""  
     ii = ii + 1  
   Next  
 End Sub  
 Private Sub CommandButton4_Click()  
   With Sheets("report")  
     .Range("b3:i200").ClearContents  
     Z = 3  
     For V = 0 To ListBox1.ListCount - 1  
       .Cells(Z, 2).Value = ListBox1.List(V, 1)  
       .Cells(Z, 3).Value = ListBox1.List(V, 2)  
       .Cells(Z, 4).Value = ListBox1.List(V, 3)  
       .Cells(Z, 5).Value = ListBox1.List(V, 4)  
       .Cells(Z, 6).Value = ListBox1.List(V, 5)  
       .Cells(Z, 7).Value = ListBox1.List(V, 6)  
       .Cells(Z, 8).Value = ListBox1.List(V, 7)  
       .Cells(Z, 9).Value = ListBox1.List(V, 8)  
       Z = Z + 1  
     Next  
   End With  
 End Sub  
 Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)  
   On Error Resume Next  
   ii = 2  
   For i = 0 To Me.ListBox1.ColumnCount  
     Me.Controls("TextBox" & ii).Value = Me.ListBox1.List(ListBox1.ListIndex, i)  
     ii = ii + 1  
   Next  
 End Sub  
 Private Sub TextBox1_Change()  
   On Error Resume Next  
   Dim ws As Worksheet  
   Dim V As Integer  
   Dim LastRow As Integer  
   Dim M As String  
   Dim Q, F  
   ListBox1.Clear  
   If TextBox1.Text = "" Then GoTo 1  
   M = TextBox1.Text  
   Set ws = Sheets("Data")  
   With ws  
     x = ComboBox1.ListIndex + 2  
     LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row  
     Set Q = Range(.Cells(2, x), .Cells(LastRow, x)).Find(M)  
     If Not Q Is Nothing Then  
       F = Q.Address  
       Do  
         If Application.WorksheetFunction.Search(M, Q, 0) = 1 Then  
           ListBox1.AddItem Q.Row  
           ListBox1.List(V, 1) = .Cells(Q.Row, 2).Value  
           ListBox1.List(V, 2) = .Cells(Q.Row, 3).Value  
           ListBox1.List(V, 3) = .Cells(Q.Row, 4).Text  
           ListBox1.List(V, 4) = .Cells(Q.Row, 5).Value  
           ListBox1.List(V, 5) = .Cells(Q.Row, 6).Value  
           ListBox1.List(V, 6) = .Cells(Q.Row, 7).Value  
           ListBox1.List(V, 7) = .Cells(Q.Row, 8).Value  
           ListBox1.List(V, 8) = .Cells(Q.Row, 9).Value  
           V = V + 1  
         End If  
         Set Q = Range(.Cells(2, x), .Cells(LastRow, x)).FindNext(Q)  
       Loop While Not Q Is Nothing And Q.Address <> F  
     End If  
   End With  
 1 End Sub  

لتحميل الملف اضغط هنا

اعداد / ياسر العربي

تحياتي

طباعة كروت الموظفين (كارنيه الموظف) اكسيل

بسم الله الرحمن الرحيم

اقدم لكم طريقة لطباعة كروت الموظفين

وهي عن طريق فورم نضع عليه كل متطلبات الكارت

من بيانات وشعار الشركة وصورة الموظف

  

هذه صورة للمثال

تستطيعوا التعديل في البيانات لما يناسب متطلباتكم

خلفية الكارت مصممة بالفوتوشوب

وتم وضع تكتست بوكس واداة صورة لعرض صورة الموظف

الكود المستخدم داخل الملف

 #If VBA7 Then  
   Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long  
   Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long  
   Private Declare PtrSafe Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long  
   Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hWnd As LongPtr) As Long  
 #Else  
   Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long  
   Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long  
   Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long  
   Private Declare Function DrawMenuBar Lib "User32" (ByVal hWnd As Long) As Long  
 #End If  
 Const GWL_STYLE = -16  
 Const WS_CAPTION = &HC00000  
 Const WS_SYSMENU = &H80000  
 Private Sub CommandButton1_Click()  
   Dim x As Long  
   Dim y As Long  
   x = Sheet2.Range("a1").End(xlDown).Value  
   Do  
     If TextBox1.Value >= x Then GoTo 1  
     CommandButton1.Visible = False  
     CommandButton2.Visible = False  
     SpinButton1.Visible = False  
     Me.PrintForm  
     TextBox1.Value = TextBox1.Value + 1  
   Loop  
 1  CommandButton1.Visible = True  
   CommandButton2.Visible = True  
   SpinButton1.Visible = True  
   MsgBox "Êã ØÈÇÚÉ ÇáÈØÇÞÇÊ"  
 End Sub  
 Private Sub CommandButton2_Click()  
   End  
 End Sub  
 Private Sub CommandButton3_Click()  
   CommandButton1.Visible = False  
   CommandButton2.Visible = False  
   CommandButton3.Visible = False  
   SpinButton1.Visible = False  
   Me.PrintForm  
   CommandButton1.Visible = True  
   CommandButton2.Visible = True  
   CommandButton3.Visible = True  
   SpinButton1.Visible = True  
   MsgBox "Êã ØÈÇÚÉ ÇáßÇÑÊ"  
 End Sub  
 Private Sub TextBox1_Change()  
   Dim x As Long  
   Dim MyPath As String  
   x = TextBox1.Value  
   On Error Resume Next  
   TextBox2.Text = Sheet2.Application.WorksheetFunction.VLookup(x, Sheet2.Range("a1:f100"), 2, 0)  
   TextBox3.Text = Sheet2.Application.WorksheetFunction.VLookup(x, Sheet2.Range("a1:f100"), 5, 0)  
   TextBox4.Text = Sheet2.Application.WorksheetFunction.VLookup(x, Sheet2.Range("a1:f100"), 4, 0)  
   TextBox6.Text = Sheet2.Application.WorksheetFunction.VLookup(x, Sheet2.Range("a1:f100"), 3, 0)  
   MyPath = ThisWorkbook.Path & "\photo\"  
   If TextBox6.Text = "" Then  
     FullImagePath = MyPath + "1000.jpg"  
     Image1.Picture = LoadPicture(FullImagePath)  
   Else  
     FullImagePath = MyPath + TextBox1.Value  
     On Error GoTo 88  
     Image1.Picture = LoadPicture(MyPath & x & ".jpg")  
 88   If Err Then xx  'MsgBox "ÇáÕæÑÉ ÛíÑ ãæÌæÏÉ ÈãÓÇÑåÇ"  
   End If  
 End Sub  
 Private Sub UserForm_Activate()  
   Dim x As Long  
   Dim MyPath As String  
   x = TextBox1.Value  
   On Error Resume Next  
   TextBox2.Text = Sheet2.Application.WorksheetFunction.VLookup(x, Sheet2.Range("a1:f100"), 2, 0)  
   TextBox3.Text = Sheet2.Application.WorksheetFunction.VLookup(x, Sheet2.Range("a1:f100"), 5, 0)  
   TextBox4.Text = Sheet2.Application.WorksheetFunction.VLookup(x, Sheet2.Range("a1:f100"), 4, 0)  
   TextBox6.Text = Sheet2.Application.WorksheetFunction.VLookup(x, Sheet2.Range("a1:f100"), 3, 0)  
   MyPath = ThisWorkbook.Path & "\photo\"  
   If TextBox6.Text = "" Then  
     FullImagePath = MyPath + "1000.jpg"  
     Image1.Picture = LoadPicture(FullImagePath)  
   Else  
     FullImagePath = MyPath + TextBox1.Value  
     On Error GoTo 88  
     Image1.Picture = LoadPicture(MyPath & x & ".jpg")  
 88   If Err Then xx  'MsgBox "ÇáÕæÑÉ ÛíÑ ãæÌæÏÉ ÈãÓÇÑåÇ"  
   End If  
 End Sub  
 Private Sub UserForm_Initialize()  
   Dim lngWindow As Long, lFrmHdl As Long  
   lFrmHdl = FindWindow(vbNullString, Me.Caption)  
   lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE)  
   lngWindow = lngWindow And (Not WS_CAPTION)  
   Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow)  
   Call DrawMenuBar(lFrmHdl)  
 End Sub  
 Private Sub SpinButton1_SpinDown()  
   Dim x As Long  
   On Error Resume Next  
   x = Sheet2.Range("a1").End(xlDown).Value  
   If x = TextBox1.Text Then  
     MsgBox "åÐÇ ÇÎÑ ÓÌá"  
   Else  
     TextBox1.Text = TextBox1.Text + 1  
   End If  
 End Sub  
 Private Sub SpinButton1_SpinUp()  
   Dim x As Long  
   On Error Resume Next  
   x = Sheet2.Range("a2").Value  
   If x = TextBox1.Text Then  
     MsgBox " åÐÇ Çæá ÓÌá"  
   Else  
     TextBox1.Text = TextBox1.Text - 1  
   End If  
 End Sub  
 Sub xx()  
   MsgBox ("ÇáÕæÑÉÛíÑ ãæÌæÏÉÈÇáãÓÇÑ")  
   MyPath = ThisWorkbook.Path & "\photo\"  
   FullImagePath = MyPath + "999.jpg"  
   UserForm1.Image1.Picture = LoadPicture(FullImagePath)  
 End Sub  

لتحميل المثال اضغط هنا

اعداد / ياسر العربي

تقبلو تحياتي

http://up.top4top.net/downloadf-170ivrj1-rar.html

الاستغناء عن الليست بوكس واستبدالها بالـ Spreadsheet

بسم الله الرحمن الرحيم

لمن يريد الاستغناء عن الليست بوكس تفضلوا

اليوم  اقدم لكم طريقة البحث عن طريق الا  Spreadsheet

قمت بعمل مثال بسيط لجلب البيانات المفلترة الى الفورم ووضعها داخل Spreadsheet

وطريقة اضافة هذه الاداة كما بالصور الموضحة

والكود المستخدم داخل الفورم في حدث التغيير للتكست بوكس

Private Sub TextBox1_Change()
    Dim last As Long
    Dim last2 As Long
    last = Spreadsheet1.ActiveSheet.Range("a10000").End(xlUp).Row
    Application.ScreenUpdating = False
    If TextBox1.Text = "" Then
        Spreadsheet1.ActiveSheet.Range("a1:k" & last).ClearContents
    Else
        Spreadsheet1.ActiveSheet.Range("a1:k" & last).ClearContents
        ActiveSheet.Range("$A$2:$K$2000").AutoFilter Field:=5, Criteria1:="" & TextBox1.Text & "*", _
                                                     Operator:=xlAnd
        last2 = ActiveSheet.Range("a10000").End(xlUp).Row
        Sheet1.Range("a1:k" & last2).Copy
        Spreadsheet1.ActiveSheet.Range("a1").Paste
        Application.CutCopyMode = False
        ActiveSheet.AutoFilterMode = False
        Application.ScreenUpdating = True
    End If
End Sub

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

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

للتحميل اضغط هنا

تقريبا تحتاج اوفيس2003 بالاساس او الملف OWC11.DLL تحديدا

فاذا قابلتكم مشاكل لعدم وجود الملف على الجهاز

يرجى تحميل المرفق التالي به الشرح والاداة وبرنامج تشغيل الاداة 

تحميل الشرح لحل مشكلة عدم وجود الملف  

تقبلو تحياتي

اعداد / ياسر العربي

http://up.top4top.net/downloadf-157jsm01-rar.html 

شرح - تشغيل برنامجك بدون تفعيل الماكرو لمن يعاني من مشاكل تفعيل الماكرو

السلام عليكم

اليوم اضع لكم شرح  حل لموضوع تفعيل الماكرو عن طريق لغة برمجة الفيجوال بيسك 6

بداية الشرح اولا سنقوم بعمل مشروع جديد 

ليظهر معنا فورم واحد وهو المطلوب

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

وهذه صور من دروس سابقة لمعرفة كيفية اضافة مرجع لبرنامج الاكسيل داخل المشروع الخاص بنا

صور من درس سابق لربط الفيجوال بالاكسيل

بعد ان قمنا باضافة المرجع الخاص بالاكسيل

نأتي لمشروعنا 

دا شكل الفورم وكوده

هتضيف صورة او ليبل حسب ما تشوفه مناسب ليك

ودا بدون اي اكواد عادي

نأتي للكود نضع في الحدث load

الكود التالي

Private Sub Form_Load()
Dim Start, Finsh
Form1.Show
Start = Timer
Finsh = Start + 5
Do Until Finsh <= Timer
DoEvents
Loop
Unload Me
    Excel.Workbooks.Open App.Path + "\yasser.xlsm"
    Excel.Application.Visible = True
End Sub

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

البداية تساوي التايمر النهاية تساوي التايمر + اي وقت تضيفه لفترة عرض الفورم كشاشة افتتاحية

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

وبعد تحقق الشرط يتم غلق الفورم وفتح ملف الاكسيل وعرضه في الوضع المرئي

وبكدا يكون انتهينا من الدرس 

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

ليه

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

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

وطبعا نقوم بتحويل الملف لملف تنفيذي بعد الانتهاء

بالنسبة لمن لديه اي صعوبات في التعامل مع الفيجوال6 يتابع الدروس من اولها حتى يتثنى له انهاء هذا العمل

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

مرفق السورس كود للبرنامج لمن لا يريد وجع دماغه 

لتحميل السورس كود اضغط هنا

تقبلو تحياتي

ياسر العربي

يتبع

http://up.top4top.net/downloadf-144afoa1-rar.html