تصنيف المنتج حسب الوصف بإستخدام الـ excel

[roshet11]

السلام عليكم ورحمة الله وبركاته 
تحية طيبه .. وبعد 🌹🌹🌹
مطلوب دالة تساعدني في تصنيف المنتجات من خلال وصف العميل للطلب حيث أنه في أغلب الأحيان يقوم العميل بكتابة المنتج بطريقة خاطئه أو باللغه العربية أو العكس لذالك جائتني فكره أن أقوم بعمل ملف excel وإستبدال الأخطاء و الكلمات ولكن أخذت وقت طويل وجهد كبير دون فائده .

لذلك أتمنا من الخبراء في الـ excel مساعدتي في ذالك .

يوجد بالمرفق ملف excel وبه شرح الفكره المطلوبه

تصنيف الوصف.xlsx

[سليم حاصبيا]

ضع كل احتمالات الكتابة في عامود واحد (دون فراغات) ودون كلمات لا معنى لها ( الاسهم الزرقاء)
و في عامود اخر ما تريد استبداله
كما في هذه الصورة

 

[سليم حاصبيا]

قلت دون كلمات لا معنى لها

هل هناك شركة باسم   غشاخخ  أو  لخخخلث

[roshet11]

هذه أخطاء متوقعه من العميل مثل عدم تغير اللغة في لوحة المفاتيح
لخخخلث google
غشاخخ  yahoo

تم تعديل أكتوبر 18, 2020 بواسطه mohamedabofayz

[محي الدين ابو البشر]

حسب ما فهمت 

مع العلم   (لخخخلث google
غشاخخ  yahoo) هماك خطأ في جدول التصنيفات

تصنيف الوصف.xlsm

[محي الدين ابو البشر]

عفواً

مع العلم   (لخخخلث google
غشاخخ  yahoo) هماك خطأ في جدول البيان

احتياطاً

Sub test()
    With Sheet1
        lr = .Cells(Rows.Count, 2).End(xlUp).Row
        For i = 2 To lr
            x = Split(.Cells(i, 2), " ")
            Set fin = Sheet2.Range("b2:d20").Find(x(4))
            .Cells(i, 3) = Sheet2.Cells(1, fin.Column)
        Next
    End With

End Sub

 

تصنيف الوصف.xlsm

[سليم حاصبيا]

بعد ادن اخي محي الدين و زيادة في اثراء الموضوع 

هذا الكود

Option Explicit
Sub test_1()
Dim arr(), i%, t%, itm, col%
Dim B As Worksheet
Dim Tas As Worksheet

Set B = Sheets("البيان")
Set Tas = Sheets("التصنيفات")
B.Range("D2").CurrentRegion.ClearContents
Dim Rg As Range
Set Rg = Tas.Range("B2:D20")
    For i = 1 To Rg.Cells.Count
        If Rg.Cells(i) <> "" Then
          ReDim Preserve arr(t)
          arr(t) = Rg.Cells(i)
          t = t + 1
        End If
     Next
 t = 2

For i = 2 To 9
    For Each itm In arr
        If InStr(B.Cells(i, 2), itm) Then
          col = Rg.Find(itm, lookat:=1).Column
          B.Cells(t, 4) = Replace(B.Cells(i, 2), _
          itm, Tas.Cells(1, col))
           t = t + 1: Exit For
        End If
     Next itm

Next i

 
End Sub

الملف مرفق

 

Mh_Fayz.xlsm

[roshet11]

شكراً شكراً 🌹 جزاك الله كل خير أخ محي الدين ابو البشر ربي يسعدك ويوفقك صحيح أخر تصنيف للوصف كان خطاء للتأكد من النتيجه النهائيه 
الملف عباره عن مثال وليس طبيعة العمل مختلف .

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

وشكراً 🥰 لكل الاخوة القائمين علي أمر هذا المنتدي 

والحمدلله أنك نبهتني جزاك الله كل خير 🌹
يستهلون أكثر من أعجاب والله كل التحيه و التقدير 🤩 

[محي الدين ابو البشر]

شكراً لك أخ roshet11 على الدعاء الطيب ولك مثله أضعافاً مضاعفة

أيضاً

يمكن أن يكون هكذا

Sub test()
    With Sheet1
        lr = .Cells(Rows.Count, 2).End(xlUp).Row
        For i = 2 To lr
            x = Split(.Cells(i, 2), " ")
            Set fin = Sheet2.Range("b2:d20").Find(x(4))
            .Cells(i, 3) = Sheet2.Cells(1, fin.Column)
            x(4) = Sheet2.Cells(1, fin.Column)
            x = Join(x, " ")
            .Cells(i, 6) = x
        Next
    End With

End Sub

 

تم تعديل أكتوبر 19, 2020 بواسطه محي الدين ابو البشر

[roshet11]

تظهر لي هذه المشكله 

[محي الدين ابو البشر]

??

تصنيف الوصف.xlsm

[roshet11]

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

[محي الدين ابو البشر]

ماذ عن هذا

Sub test2()
Dim lr, i
Dim fin As Object
Dim x As Variant
    With Sheet1
        lr = .Cells(Rows.Count, 2).End(xlUp).Row
        For i = 2 To lr
            x = Split(.Cells(i, 2), " ")
            Set fin = Sheet2.Range("b2:d20").Find(x(4))
            If fin <> "" Then
            .Cells(i, 3) = Sheet2.Cells(1, fin.Column)
            x(4) = Sheet2.Cells(1, fin.Column)
            x = Join(x, " ")
            .Cells(i, 5) = x
            Else
            .Cells(i, 5) = Join(x, " ")
            End If
        Next
    End With
End Sub

 

[roshet11]

 يجي رسالة تحذرية محي الدين ابو البشر 
الملف المرفق في توضيح أكثر 

تصنيف حسب الوصف.xlsm

[سليم حاصبيا]

تم التعديل على الملف قليلا من حيث المظهر والتنسيق

Option Explicit
Sub MY_code()
    Rem Created by Salim Hasbaya On 19/10/2020
Application.ScreenUpdating = False
    Dim B As Worksheet, Tas As Worksheet
    Dim arr()
    Dim i%, t%, col%, p%, n%, Q%, LB%
    Dim St$, itm As Variant
    Dim Rg As Range

    Set B = Sheets("البيان")
    Set Tas = Sheets("التصنيفات")
    Set Rg = Tas.Range("B1").CurrentRegion
    If Rg.Rows.Count = 1 Then GoTo Ma_Lish_Da3wa
    Set Rg = Rg.Offset(1).Resize(Rg.Rows.Count - 1)

LB = B.Cells(Rows.Count, 2).End(3).Row
B.Range("D2").CurrentRegion.ClearContents
  If LB = 1 Then GoTo Ma_Lish_Da3wa
    
    For i = 1 To Rg.Cells.Count
        If Rg.Cells(i) <> "" Then
          ReDim Preserve arr(t)
          arr(t) = Rg.Cells(i)
          t = t + 1
        End If
     Next
 t = 2
B.Range("D2").Resize(LB - 1) = _
B.Range("B2").Resize(LB - 1).Value

       '+++++++++++++Creating The Data +++++++++++++
For i = 2 To LB
 If B.Range("D" & i) <> vbNullString Then
    For Each itm In arr
        If InStr(B.Range("D" & i), itm) Then
          col = Rg.Find(itm, lookat:=1).Column
          St = Replace(B.Range("D" & i), itm, "*")
          col = Rg.Find(itm, lookat:=1).Column
          St = Replace(St, "*", Tas.Cells(1, col))
          B.Range("D" & i) = St
        End If
    Next itm
  End If
Next i
      '+++++++++++++ End Of Creating The Data +++++++++++++
Erase arr
   
ReDim arr(1 To 3)
  For i = 1 To 3
    arr(i) = Tas.Cells(1, i + 1)
  Next
p = 1
 '+++++++++++++Formating with Red Color +++++++++++++
For i = 2 To LB
    For Each itm In arr
        Do
          Q = InStr(p, B.Range("D" & i), itm)
           If Q = 0 Then Exit Do
          n = InStr(Q, B.Range("D" & i), " ")
          p = p + n + 1
          B.Range("D" & i).Characters(Q, n - Q). _
          Font.ColorIndex = 3
        Loop
        p = 1
    Next itm
Next i

'++++++++++++++End Of Formating with Red Color +++++++++++++
Ma_Lish_Da3wa:
 Set B = Nothing: Set Tas = Nothing
 Set Rg = Nothing: Erase arr
 Application.ScreenUpdating = True
End Sub

الملف من جديد مع الكودين القديم والجديد

 

Mh_Fayz _New.xlsm

[سليم حاصبيا]

مهما كانت الاعداد كبيرة الماكرو بقوم بالواجب بشكل اوتوماتيكي

هذا بالاضافة الى اماكنبة زيادة احتمالات الكتابة في شيت التصنيفات (مثلاً  يهو / فسيك/ جوجيل الخ...)

[roshet11]

أتعبتك معي أخ @سليم حاصبيا
صحيح لكن كيف أصنفهم مجموعات 
هذا الملف في توضيح أكثر 

تصنيف حسب الوصف.xlsm

[سليم حاصبيا]

قم بهذه التعديلات على الكود كما في الصورة (الغامود  ِِA في صحفة التصنيفات  فارغ تماما)

البيانات في الصفحة  " البيان " يجب ان تكون في العامود B  ابتداء من الصف رقم 2

 

[roshet11]

😔 😔
أريد أن أعرف التصنيف من خلال الوصف 

شيت التصنيفات مثل الفلتر التصنيف بالأعلى و الكلمات اللتي تدل على التصنيف بالأسفل

نفس فكرة الأخ @محي الدين ابو البشر لكن بدون تحديد نص ثابت 
 

[محي الدين ابو البشر]

         لا ادري إذا كان هذا قصدك

 

تصنيف حسب الوصف new.xlsm