فصل القيم النصية والرقمية 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  

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


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