تميز الاصناف

**ابو حمادة** · مارس 2, 2018

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

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

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

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

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

RTR.rar

RTE.JPG.73c81ddad9ede284030dccfd4d300ecb.JPG

**سليم حاصبيا** · مارس 3, 2018

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

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, 2018

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

**سليم حاصبيا** · مارس 3, 2018

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

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

**ابو حمادة** · مارس 3, 2018

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, 2018

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

RTR1.xlsm

**ابو حمادة** · مارس 3, 2018

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

**ابو حمادة** · مارس 3, 2018

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

**سليم حاصبيا** · مارس 3, 2018

الكود

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

**ابو حمادة** · مارس 3, 2018

منذ ساعه, سليم حاصبيا 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

**سليم حاصبيا** · مارس 3, 2018

يجب تحميل الملف(أو قسم منه اذا كان كبيراً) للعمل عليه

**ابو حمادة** · مارس 3, 2018

3 دقائق مضت, سليم حاصبيا said:

يجب تحميل الملف(أو قسم منه اذا كان كبيراً) للعمل عليه

الملف

TTTTT.rar

**سليم حاصبيا** · مارس 3, 2018

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

الكود

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

**ابو حمادة** · مارس 3, 2018

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) يميز كل الاصناف منصرف وارد فقط ويترك اي صنف مستبعد نهائيا

**سليم حاصبيا** · مارس 4, 2018

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

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

**ابو حمادة** · مارس 6, 2018

في ٤‏/٣‏/٢٠١٨ 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

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

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

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

تسجيل الدخول

تميز الاصناف

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

ابو حمادة

سليم حاصبيا

ابو حمادة

سليم حاصبيا

ابو حمادة

سليم حاصبيا

ابو حمادة

ابو حمادة

سليم حاصبيا

ابو حمادة

سليم حاصبيا

ابو حمادة

سليم حاصبيا

ابو حمادة

سليم حاصبيا

ابو حمادة

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information