اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

تميز الاصناف

ابو حمادة

بواسطه ابو حمادة
في منتدى الاكسيل Excel

 مشاركة

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

ابو حمادة

ابو حمادة

قام بنشر
قام بنشر

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

اساتذتي الكرام

كل  عام  وانتم بخير

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

كما موضح فى الصوره

RTR.rar

RTE.JPG.73c81ddad9ede284030dccfd4d300ecb.JPG

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

جرب هذا الماكرو 

Option Explicit

Sub Distribute_col()
Dim MY_Rg As Range
Dim x%, t%, n%
Dim k%: k = 1
Set MY_Rg = Range("a5").CurrentRegion.Columns(2)
Dim N_row As Double: N_row = MY_Rg.Rows.Count
Set MY_Rg = MY_Rg.Offset(1, 0).Resize(N_row - 1)
N_row = MY_Rg.Rows.Count
x = Int(N_row / [f1])
t = x * [f1]
  For n = 1 To N_row
    MY_Rg.Cells(n).Offset(0, 2) = "sec" & k
     If (n Mod x) = 0 Then k = k + 1
   Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$F$1" Then Exit Sub
Distribute_col
End Sub

 

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

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر
3 ساعات مضت, سليم حاصبيا said:

جرب هذا الماكرو 


Option Explicit

Sub Distribute_col()
Dim MY_Rg As Range
Dim x%, t%, n%
Dim k%: k = 1
Set MY_Rg = Range("a5").CurrentRegion.Columns(2)
Dim N_row As Double: N_row = MY_Rg.Rows.Count
Set MY_Rg = MY_Rg.Offset(1, 0).Resize(N_row - 1)
N_row = MY_Rg.Rows.Count
x = Int(N_row / [f1])
t = x * [f1]
  For n = 1 To N_row
    MY_Rg.Cells(n).Offset(0, 2) = "sec" & k
     If (n Mod x) = 0 Then k = k + 1
   Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$F$1" Then Exit Sub
Distribute_col
End Sub

 

شكرا  استاذي الغالي على المجهود 

لكن يوجد مشكله 

انظر للصورة المرفقه كي تعلم ماهي

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

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

جرب الكود الثاني الذي رفعته لك 

sadds.JPG.e6d6572d17cc56b9f7055b45cf30c88f.JPG

 

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

جرب هذا الماكرو 

Option Explicit

Sub Distribute_col()
Dim MY_Rg As Range
Dim x%, t%, n%
Dim k%: k = 1
Set MY_Rg = Range("a5").CurrentRegion.Columns(2)
Dim N_row As Double: N_row = MY_Rg.Rows.Count
Set MY_Rg = MY_Rg.Offset(1, 0).Resize(N_row - 1)
N_row = MY_Rg.Rows.Count
x = Int(N_row / [f1])
t = x * [f1]
  For n = 1 To N_row
    MY_Rg.Cells(n).Offset(0, 2) = "sec" & k
     If (n Mod x) = 0 Then k = k + 1
   Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$F$1" Then Exit Sub
Distribute_col
End Sub

 

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

Sub Distribute_col()
Application.EnableEvents = False
Dim MY_Rg As Range
Dim x%, t%, n%
Dim k%: k = 1
Dim s%: s = 1
Dim my_arr(), my_arr_Item()
Set MY_Rg = Range("a5").CurrentRegion.Columns(2)
Dim N_row As Double: N_row = MY_Rg.Rows.Count
Set MY_Rg = MY_Rg.Offset(1, 0).Resize(N_row - 1)
N_row = MY_Rg.Rows.Count
Range("D5:D" & N_row + 4).ClearContents
x = Int(N_row / [f1])
t = x * [f1]
  For n = 1 To N_row
   ReDim Preserve my_arr_Item(1 To s): my_arr_Item(s) = MY_Rg.Rows.Cells(n)
   ReDim Preserve my_arr(1 To s): my_arr(s) = "Section :" & k
   s = s + 1
    If (n Mod x) = 0 Then k = k + 1
   Next
   For i = LBound(my_arr) To UBound(my_arr)
    Cells(i + 4, 4) = Application.Index(my_arr, Application.Match(my_arr_Item(i), my_arr_Item, 0))
    Next
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$F$1" Then Exit Sub
Distribute_col1
End Sub

 

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

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر
2 ساعات مضت, سليم حاصبيا said:

جرب هذا الماكرو 


Option Explicit

Sub Distribute_col()
Dim MY_Rg As Range
Dim x%, t%, n%
Dim k%: k = 1
Set MY_Rg = Range("a5").CurrentRegion.Columns(2)
Dim N_row As Double: N_row = MY_Rg.Rows.Count
Set MY_Rg = MY_Rg.Offset(1, 0).Resize(N_row - 1)
N_row = MY_Rg.Rows.Count
x = Int(N_row / [f1])
t = x * [f1]
  For n = 1 To N_row
    MY_Rg.Cells(n).Offset(0, 2) = "sec" & k
     If (n Mod x) = 0 Then k = k + 1
   Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$F$1" Then Exit Sub
Distribute_col
End Sub

 

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


Sub Distribute_col()
Application.EnableEvents = False
Dim MY_Rg As Range
Dim x%, t%, n%
Dim k%: k = 1
Dim s%: s = 1
Dim my_arr(), my_arr_Item()
Set MY_Rg = Range("a5").CurrentRegion.Columns(2)
Dim N_row As Double: N_row = MY_Rg.Rows.Count
Set MY_Rg = MY_Rg.Offset(1, 0).Resize(N_row - 1)
N_row = MY_Rg.Rows.Count
Range("D5:D" & N_row + 4).ClearContents
x = Int(N_row / [f1])
t = x * [f1]
  For n = 1 To N_row
   ReDim Preserve my_arr_Item(1 To s): my_arr_Item(s) = MY_Rg.Rows.Cells(n)
   ReDim Preserve my_arr(1 To s): my_arr(s) = "Section :" & k
   s = s + 1
    If (n Mod x) = 0 Then k = k + 1
   Next
   For i = LBound(my_arr) To UBound(my_arr)
    Cells(i + 4, 4) = Application.Index(my_arr, Application.Match(my_arr_Item(i), my_arr_Item, 0))
    Next
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$F$1" Then Exit Sub
Distribute_col1
End Sub

 

شكرا لسعة صدرك واهتممك لك جزيل الشكر 

RTE.JPG.5c3ec7ff0ab26803d0af1f4548ddfce9.JPG

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

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر
3 ساعات مضت, سليم حاصبيا said:

الكود يعمل عندي بشكل ممتاز 

 

RTR1.xlsm

الله ينور عليك استاذي الغالى

هو دا المطلوب

ممكن بس شرح للكود عشان اعرف احطه فى الملف الاصلى

عندي الملف الاصلى عمود الصنف فى (i6)

الخليه ال فيها العدد (LM1)

العمود ال هايتم وضع التميز فيه هو (LM6)

بدايه العمل فى الصف (6)

ضع في الكود هذه الاسطر

Set MY_Rg = Range("i6").CurrentRegion

([x = Int(N_row / [LM1

Range("LM6:LM" & N_row + 5).ClearContents

("Cells(i + 5,"LM 

If Target.Address <> "$LM$1" Then Exit Sub

مكان هذه الاسطر

 Set MY_Rg = Range("a5").CurrentRegion

([x = Int(N_row / [f1

Range("D5:D" & N_row + 4).ClearContents

(Cells(i + 4, 4

If Target.Address <> "$F$1" Then Exit Sub

 

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

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر
42 دقائق مضت, ابو حمادة said:

الله ينور عليك استاذي الغالى

هو دا المطلوب

ممكن بس شرح للكود عشان اعرف احطه فى الملف الاصلى

عندي الملف الاصلى عمود الصنف فى (i6)

الخليه ال فيها العدد (LM1)

العمود ال هايتم وضع التميز فيه هو (LM6)

بدايه العمل فى الصف (6)

ضع في الكود هذه الاسطر

Set MY_Rg = Range("i6").CurrentRegion

([x = Int(N_row / [LM1

Range("LM6:LM" & N_row + 5).ClearContents

("Cells(i + 5,"LM 

If Target.Address <> "$LM$1" Then Exit Sub

مكان هذه الاسطر

 Set MY_Rg = Range("a5").CurrentRegion

([x = Int(N_row / [f1

Range("D5:D" & N_row + 4).ClearContents

(Cells(i + 4, 4

If Target.Address <> "$F$1" Then Exit Sub

 

دى  صورة من الملف الاصلي اتمنى الكود يمشي معاه انا حولت اعمله لكن للاسف معرفتش

وسف انى تعبتك معايا

trt.JPG.0862a8eadda3a090c9a392743e46d053.JPG

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

الكود 

Sub Distribute_col()
Application.EnableEvents = False
Dim MY_Rg As Range
Dim x%, n%, i%
Dim k%: k = 1
Dim s%: s = 1
Dim my_arr(), my_arr_Item()
Set MY_Rg = Range("i5").CurrentRegion
Dim N_row As Double: N_row = MY_Rg.Rows.Count
Set MY_Rg = MY_Rg.Resize(N_row - 1)
N_row = MY_Rg.Rows.Count
Range("LM6:LM" & N_row + 6).ClearContents
x = Int(N_row / [LM1])
  For n = 1 To N_row
   ReDim Preserve my_arr_Item(1 To s): my_arr_Item(s) = MY_Rg.Cells(n)
   ReDim Preserve my_arr(1 To s): my_arr(s) = "Section :" & k
   s = s + 1
    If (n Mod x) = 0 Then k = k + 1
   Next
   For i = LBound(my_arr) To UBound(my_arr)
    Cells(i + 5, "LM") = Application.Index(my_arr, Application.Match(my_arr_Item(i), my_arr_Item, 0))
    Next
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$LM$1" Then Exit Sub
Distribute_col
End Sub

 

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

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر
منذ ساعه, سليم حاصبيا said:

الكود 


Sub Distribute_col()
Application.EnableEvents = False
Dim MY_Rg As Range
Dim x%, n%, i%
Dim k%: k = 1
Dim s%: s = 1
Dim my_arr(), my_arr_Item()
Set MY_Rg = Range("i5").CurrentRegion
Dim N_row As Double: N_row = MY_Rg.Rows.Count
Set MY_Rg = MY_Rg.Resize(N_row - 1)
N_row = MY_Rg.Rows.Count
Range("LM6:LM" & N_row + 6).ClearContents
x = Int(N_row / [LM1])
  For n = 1 To N_row
   ReDim Preserve my_arr_Item(1 To s): my_arr_Item(s) = MY_Rg.Cells(n)
   ReDim Preserve my_arr(1 To s): my_arr(s) = "Section :" & k
   s = s + 1
    If (n Mod x) = 0 Then k = k + 1
   Next
   For i = LBound(my_arr) To UBound(my_arr)
    Cells(i + 5, "LM") = Application.Index(my_arr, Application.Match(my_arr_Item(i), my_arr_Item, 0))
    Next
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$LM$1" Then Exit Sub
Distribute_col
End Sub

 

كدا تمام استاذي الغالى باقي حاجه اخيره

كل صنف ينقسم الى   ( وارد - منصرف - مستبعد )

دا فى العمود (E)

محتاج اضافة شرط للكود 

لو كتبت منصرف في الخليه (LN1) 

يوضع كلمة التميز  لكل الاصناف المنصرفه

ولو كتبت وارد يوضع كلمة التميز للاصناف الواردة

واستبعاد اي صنف ( مستبعد ) من التميز

ولو كتبت الكل يوضع كلمة التميز للوارد والمنصرف  واستبعاد اي صنف مستبعد 

كما واضح فى الصورة

واسف للاطاله

TEXT.JPG.d93e909de80074cbd95d98fc5b11bce6.JPG

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

تم معالجة الامر(اختر المطلوب مستبعد وارد الخ....من القائمة المنسدلة)

الكود 

Sub Distribute_col()
Application.EnableEvents = False
Dim MY_Rg As Range
Dim x%, n%, i%
Dim k%: k = 1
Dim s%: s = 1
Dim my_arr(), my_arr_Item()
Set MY_Rg = Range("i5").CurrentRegion
Dim N_row As Double: N_row = MY_Rg.Rows.Count
Set MY_Rg = MY_Rg.Resize(N_row - 1)
N_row = MY_Rg.Rows.Count
Dim st_to_del$
Range("LM6:LM" & N_row + 6).ClearContents
x = Int(N_row / [LM1])
  For n = 1 To N_row
   ReDim Preserve my_arr_Item(1 To s): my_arr_Item(s) = MY_Rg.Cells(n)
   ReDim Preserve my_arr(1 To s): my_arr(s) = "Section :" & k
   s = s + 1
    If (n Mod x) = 0 Then k = k + 1
   Next
   For i = LBound(my_arr) To UBound(my_arr)
    Cells(i + 5, "LM") = Application.Index(my_arr, Application.Match(my_arr_Item(i), my_arr_Item, 0))
    Next
    st_to_del = [LN1]
    If st_to_del = "ALL" Then GoTo exit_Me
    For i = 6 To UBound(my_arr) + 5
     If Range("e" & i) <> st_to_del Then
     Range("LM" & i) = vbNullString
     End If
    Next
exit_Me:
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$LM$1" Then Exit Sub
Distribute_col
End Sub

الملف

 

RTR1salim.rar

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

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر
7 دقائق مضت, سليم حاصبيا said:

تم معالجة الامر(اختر المطلوب مستبعد وارد الخ....من القائمة المنسدلة)

الكود 


Sub Distribute_col()
Application.EnableEvents = False
Dim MY_Rg As Range
Dim x%, n%, i%
Dim k%: k = 1
Dim s%: s = 1
Dim my_arr(), my_arr_Item()
Set MY_Rg = Range("i5").CurrentRegion
Dim N_row As Double: N_row = MY_Rg.Rows.Count
Set MY_Rg = MY_Rg.Resize(N_row - 1)
N_row = MY_Rg.Rows.Count
Dim st_to_del$
Range("LM6:LM" & N_row + 6).ClearContents
x = Int(N_row / [LM1])
  For n = 1 To N_row
   ReDim Preserve my_arr_Item(1 To s): my_arr_Item(s) = MY_Rg.Cells(n)
   ReDim Preserve my_arr(1 To s): my_arr(s) = "Section :" & k
   s = s + 1
    If (n Mod x) = 0 Then k = k + 1
   Next
   For i = LBound(my_arr) To UBound(my_arr)
    Cells(i + 5, "LM") = Application.Index(my_arr, Application.Match(my_arr_Item(i), my_arr_Item, 0))
    Next
    st_to_del = [LN1]
    If st_to_del = "ALL" Then GoTo exit_Me
    For i = 6 To UBound(my_arr) + 5
     If Range("e" & i) <> st_to_del Then
     Range("LM" & i) = vbNullString
     End If
    Next
exit_Me:
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$LM$1" Then Exit Sub
Distribute_col
End Sub

الملف

 

RTR1salim.rar

الله ينور عليك استذي الفاضل

بس فيه حاجه عند اختيار (ALL) بيوضع كلمة  التميز للاصناف المستبعدة ايضا ودي انا مش عايزها المستبعد يتركه فى كل الاحوال

المطلوب عند اختيار (ALL) يميز كل الاصناف منصرف وارد فقط ويترك اي صنف مستبعد نهائيا

 

 

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

الكود الجديد لعمل هذا 

Sub Distribute_col()
Application.EnableEvents = False
Dim MY_Rg As Range
Dim x%, n%, i%
Dim k%: k = 1
Dim s%: s = 1
Dim my_arr(), my_arr_Item()
Set MY_Rg = Range("i5").CurrentRegion
Dim N_row As Double: N_row = MY_Rg.Rows.Count
Set MY_Rg = MY_Rg.Resize(N_row - 1)
N_row = MY_Rg.Rows.Count
Dim st_to_del$
Range("LM6:LM" & N_row + 6).ClearContents
x = Int(N_row / [LM1])
  For n = 1 To N_row
   ReDim Preserve my_arr_Item(1 To s)
   my_arr_Item(s) = MY_Rg.Cells(n)
   ReDim Preserve my_arr(1 To s)
   my_arr(s) = "Section :" & k
   s = s + 1
    If (n Mod x) = 0 Then k = k + 1
   Next
   For i = LBound(my_arr) To UBound(my_arr)
    Cells(i + 5, "LM") = Application.Index(my_arr, _
    Application.Match(my_arr_Item(i), my_arr_Item, 0))
    Next
    st_to_del = [LN1]
    If st_to_del = "ALL" Then GoTo exit_Me
    For i = 6 To UBound(my_arr) + 5
     If Range("e" & i) <> st_to_del Then
     Range("LM" & i) = vbNullString
     End If
    Next
    GoTo 2
exit_Me:
'================================
For i = 6 To UBound(my_arr) + 5
     If Range("e" & i) = "مستبعد" Then
     Range("LM" & i) = vbNullString
     End If
    Next
2:
'=============================
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$LM$1" _
Or Target.Address = "$LN$1" Then _
Distribute_col

End Sub

 

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

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر
في ٤‏/٣‏/٢٠١٨ at 07:18, سليم حاصبيا said:

الكود الجديد لعمل هذا 


Sub Distribute_col()
Application.EnableEvents = False
Dim MY_Rg As Range
Dim x%, n%, i%
Dim k%: k = 1
Dim s%: s = 1
Dim my_arr(), my_arr_Item()
Set MY_Rg = Range("i5").CurrentRegion
Dim N_row As Double: N_row = MY_Rg.Rows.Count
Set MY_Rg = MY_Rg.Resize(N_row - 1)
N_row = MY_Rg.Rows.Count
Dim st_to_del$
Range("LM6:LM" & N_row + 6).ClearContents
x = Int(N_row / [LM1])
  For n = 1 To N_row
   ReDim Preserve my_arr_Item(1 To s)
   my_arr_Item(s) = MY_Rg.Cells(n)
   ReDim Preserve my_arr(1 To s)
   my_arr(s) = "Section :" & k
   s = s + 1
    If (n Mod x) = 0 Then k = k + 1
   Next
   For i = LBound(my_arr) To UBound(my_arr)
    Cells(i + 5, "LM") = Application.Index(my_arr, _
    Application.Match(my_arr_Item(i), my_arr_Item, 0))
    Next
    st_to_del = [LN1]
    If st_to_del = "ALL" Then GoTo exit_Me
    For i = 6 To UBound(my_arr) + 5
     If Range("e" & i) <> st_to_del Then
     Range("LM" & i) = vbNullString
     End If
    Next
    GoTo 2
exit_Me:
'================================
For i = 6 To UBound(my_arr) + 5
     If Range("e" & i) = "مستبعد" Then
     Range("LM" & i) = vbNullString
     End If
    Next
2:
'=============================
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$LM$1" _
Or Target.Address = "$LN$1" Then _
Distribute_col

End Sub

 

الف الف شكر استاذي الغالي على هذا المجهود الرائع

هذا هو المطلوب

جزاك الله كل خير

 

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

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

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

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

Important Information

  I accept