اذهب الي المحتوي
أوفيسنا

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


roshet11
إذهب إلى أفضل إجابة Solved by محي الدين ابو البشر,

الردود الموصى بها

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

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


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

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

رابط هذا التعليق
شارك

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

 

Pic_Goog.png

  • Like 1
رابط هذا التعليق
شارك

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

تم تعديل بواسطه mohamedabofayz
رابط هذا التعليق
شارك

  • أفضل إجابة

عفواً

مع العلم   (لخخخلث 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

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك

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

هذا الكود

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

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك

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

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

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

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

رابط هذا التعليق
شارك

شكراً لك أخ 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

 

تم تعديل بواسطه محي الدين ابو البشر
  • Thanks 1
رابط هذا التعليق
شارك

ماذ عن هذا

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

 

  • Sad 1
رابط هذا التعليق
شارك

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

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

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك

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

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

رابط هذا التعليق
شارك

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

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

 

Data_Fil.png

  • Sad 1
رابط هذا التعليق
شارك

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

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

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

 

رابط هذا التعليق
شارك

زائر
هذا الموضوع مغلق.
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information