Jump to content
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


Go to solution Solved by محي الدين ابو البشر,

Recommended Posts

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

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


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

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

Link to post
Share on other sites

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

 

Pic_Goog.png

  • Like 1
Link to post
Share on other sites
  • Ali Mohamed Ali changed the title to تصنيف المنتج حسب الوصف بإستخدام الـ excel

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

Edited by mohamedabofayz
Link to post
Share on other sites
  • Solution

عفواً

مع العلم   (لخخخلث 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
Link to post
Share on other sites

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

هذا الكود

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
Link to post
Share on other sites

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

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

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

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

Link to post
Share on other sites

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

 

Edited by محي الدين ابو البشر
  • Thanks 1
Link to post
Share on other sites

ماذ عن هذا

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
Link to post
Share on other sites

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

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
Link to post
Share on other sites

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

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

Link to post
Share on other sites

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

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

 

Data_Fil.png

  • Sad 1
Link to post
Share on other sites

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

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

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

 

Link to post
Share on other sites
Guest
This topic is now closed to further replies.
  • Recently Browsing   0 members

    No registered users viewing this page.

×
×
  • Create New...