كود ترقيم للاصناف

[ابو حمادة]

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

ملف مرفق مثال.rar

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

لا حاجة للكود تكفي معادلة واحدة توضع في الخلية E2  وتسحب نزولاً

(هذا اذا كنت قد فهمت السؤال جيداً)

في حال الحطأ ارفع ملفاً يحتوي نموذجاً عن النتائج المتوقعة

=IFERROR(IF(ROWS($E$1:E2)>COUNTA(D:D),"",IF(COUNTIF($D$2:D2,D2)=1,MAX($E$1:E1)+1,INDEX($E$1:$E1,MATCH(D2,$D$1:$D1,0)))),"")

الملف مرفق

 

مثال سليم.rar

[ابو حمادة]

الان, سليم حاصبيا said:

لا حاجة للكود تكفي معادلة واحدة توضع في الخلية E2  وتسحب نزولاً

(هذا اذا كنت قد فهمت السؤال جيداً)

في حال الحطأ ارفع ملفاً يحتوي نموذجاً عن النتائج المتوقعة

=IFERROR(IF(ROWS($E$1:E2)>COUNTA(D:D),"",IF(COUNTIF($D$2:D2,D2)=1,MAX($E$1:E1)+1,INDEX($E$1:$E1,MATCH(D2,$D$1:$D1,0)))),"")

الملف مرفق

 

مثال سليم.rar

شكرا لك استاذي الغالى على اهتمامك  انا اعلم هذه المعادله ولكن انا بسبب تقل الملف بسبب المعادلات كرهت وجود معادلات داخل اى عمل على الاكسل 

اريد كود افضل لتخفيف الملف 

علما بان هذه المعادله بها خطأ ربما لعدم توصيل المعلومه مني  لحضرتك او خطأ في كتابتها هي بتوضع لكل صنف رقم لنى اريد عمل تسلسل لكل صنف 1,2,3,4,5 وهكذت

مطلوب باختصار بالكود

وضع تسلسل لكل صنف على حده بمعني 

اسم الصنف وليكن الاثاث يبدا الترقيم من 1 ثم 2 ثم 3 وهكذا لكل صنف على حدة 

ولك منى جزيل الشكر اخى الغالي

 

تم تعديل سبتمبر 12, 2017 بواسطه ابو حمادة

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

45 دقائق مضت, ابو حمادة said:

شكرا لك استاذي الغالى على اهتمامك  انا اعلم هذه المعادله ولكن انا بسبب تقل الملف بسبب المعادلات كرهت وجود معادلات داخل اى عمل على الاكسل 

اريد كود افضل لتخفيف الملف 

جرب هذا الكود (استبدل اسم الورقة الى Data لسهولة التعامل مع اللفة الاحنبية)

Option Explicit
Option Base 1
Sub Numeration()
 Dim sh As Worksheet
 Dim arr()
 Dim lr%, k%, x%
 k = 1
 Set sh = Sheets("Data")
 With sh
            lr = .Cells(Rows.Count, 4).End(3).Row
           .Range("c2:c" & lr).ClearContents
    For x = 2 To lr
           If Application.CountIf(.Range("d2" & ":d" & x), .Range("d" & x)) = 1 Then
           ReDim Preserve arr(1 To k): arr(k) = .Range("d" & x): k = k + 1
           End If
     Next
         For k = 2 To lr
        .Range("c" & k) = Application.Match(.Range("d" & k), arr, 0)
       Next
  End With
Erase arr
End Sub

الملف مرفق

 

2مثال سليم.rar

[ابو حمادة]

الان, سليم حاصبيا said:

جرب هذا الكود (استبدل اسم الورقة الى Data لسهولة التعامل مع اللفة الاحنبية)

Option Explicit
Option Base 1
Sub Numeration()
 Dim sh As Worksheet
 Dim arr()
 Dim lr%, k%, x%
 k = 1
 Set sh = Sheets("Data")
 With sh
            lr = .Cells(Rows.Count, 4).End(3).Row
           .Range("c2:c" & lr).ClearContents
    For x = 2 To lr
           If Application.CountIf(.Range("d2" & ":d" & x), .Range("d" & x)) = 1 Then
           ReDim Preserve arr(1 To k): arr(k) = .Range("d" & x): k = k + 1
           End If
     Next
         For k = 2 To lr
        .Range("c" & k) = Application.Match(.Range("d" & k), arr, 0)
       Next
  End With
Erase arr
End Sub

الملف مرفق

 

2مثال سليم.rar

اخي واستاذي الغالى شكرا لمجهودك ولكن يظهر اننى لم اجيد توصيل المعلومه صحيحه لحضرتك 

المطلوب هو وضع تسلسل كل صنف على حده وليس رقم ثابت لكل صنف اتمنى تركز في الصورة المرفقه 

 

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

27 دقائق مضت, ابو حمادة said:

اخي واستاذي الغالى شكرا لمجهودك ولكن يظهر اننى لم اجيد توصيل المعلومه صحيحه لحضرتك 

المطلوب هو وضع تسلسل كل صنف على حده وليس رقم ثابت لكل صنف اتمنى تركز في الصورة المرفقه 

 

الماكرو المطلوب

Sub numeraton2()
Dim sh As Worksheet
 Dim arr()
 Dim lr%, k%, i%
 Set sh = Sheets("Data")
 k = 1
'=========================
    With sh
                lr = .Cells(Rows.Count, 4).End(3).Row
                   .Range("b2:b" & lr).ClearContents
            For i = 2 To lr
                   If Application.CountIf(.Range("d2" & ":d" & i), .Range("d" & i)) = 1 Then
                   ReDim Preserve arr(1 To k): arr(k) = .Range("d" & i): k = k + 1
                   End If
             Next
   k = 1
             For i = 2 To lr Step UBound(arr)
               .Range("b" & i) = k: k = k + 1
             Next
     End With
      Erase arr
End Sub

 

[ابو حمادة]

الان, سليم حاصبيا said:

الماكرو المطلوب

Sub numeraton2()
Dim sh As Worksheet
 Dim arr()
 Dim lr%, k%, i%
 Set sh = Sheets("Data")
 k = 1
'=========================
    With sh
                lr = .Cells(Rows.Count, 4).End(3).Row
                   .Range("b2:b" & lr).ClearContents
            For i = 2 To lr
                   If Application.CountIf(.Range("d2" & ":d" & i), .Range("d" & i)) = 1 Then
                   ReDim Preserve arr(1 To k): arr(k) = .Range("d" & i): k = k + 1
                   End If
             Next
   k = 1
             For i = 2 To lr Step UBound(arr)
               .Range("b" & i) = k: k = k + 1
             Next
     End With
      Erase arr
End Sub

 

بصراحه مش عارف انا حاسس اني مش عارف اوصلك المعلومه او حضرتك مش فاهم قصدي 

بص  مثال

عندي مثلا  صنف اسمه الاثاث يكون التسلسل كالاتي

الاثاث  = 1

الاثاث  = 2 

الاثاث  = 3

وهكذا لاخر الصنف يعني لو عندي 10 انواع من الاثاث يتم ترقيم من 1 الى 10 

ودا يطبق لكل الاصناف اي صنف يبدا ب 1 وينتهي بعدد الصنف  

يعني لو فرض عندي 10 اصناف في الشيت يتم ترقيم كل صنف على حده كانك بتعمل تسلسل 1-2-3-4-5-6-7-8-9-10  وهكذا

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

واخيرا شكرا لمجهودك واسف لو تقلت عليك

تم الترقيم المطلوب يدوي لكي تعرف ما اريده في الكود

انظر للصورة المرفقه

 

 

تم تعديل سبتمبر 12, 2017 بواسطه ابو حمادة

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

13 دقائق مضت, ابو حمادة said:

بصراحه مش عارف انا حاسس اني مش عارف اوصلك المعلومه او حضرتك مش فاهم قصدي 

بص  مثال

عندي مثلا  صنف اسمه الاثاث يكون التسلسل كالاتي

الاثاث  = 1

الاثاث  = 2 

الاثاث  = 3

وهكذا لاخر الصنف يعني لو عندي 10 انواع من الاثاث يتم ترقيم من 1 الى 10 

ودا يطبق لكل الاصناف اي صنف يبدا ب 1 وينتهي بعدد الصنف  

يعني لو فرض عندي 10 اصناف في الشيت يتم ترقيم كل صنف على حده كانك بتعمل تسلسل 1-2-3-4-5-6-7-8-9-10  وهكذا

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

واخيرا شكرا لمجهودك واسف لو تقلت عليك

جرب هذه المعادلة في الخلية B2 ,و اسجب نزولاُ لو كان المطلوب نحولها الى كود

=INT((ROWS($A$1:A1)-1)/8)+1

 

[ابو حمادة]

الان, سليم حاصبيا said:

جرب هذه المعادلة في الخلية B2 ,و اسجب نزولاُ لو كان المطلوب نحولها الى كود

=INT((ROWS($A$1:A1)-1)/8)+1

 

استاذي الفاضل ليست هذه المعادله  هي المطلوبة 

ببساطه شديده

اي كلمه مكرره في العمود (D) يتم عدها  يعني اى كلمه مكرره يتم وضع تسلسل لها من 1 الى اخر عددها

ببساطه اكثر عندك في الملف كلمة ( الاثاث ) مكرره كام مره امامك بالملف المرسل هتلقيها مكرره 4 مرات يكون المسلسل 4,3,2,1  

واى كلمة اخرى مكرره يتم وضع تسلسل لها يعني يوجد اصنااف مكرره 5 مرات واصناف مكرره 10 مرات واصناف مكرره 100 مره يكون التسلسل كالتالي

الكلمه المكرره 5 مرات = من 1 الى 5 يعني كل كلمه تاخد رقم اكبر من ال قبلها بواحد 

وهكذا لكل كلمة مكرره حسب عدد تكرارها في العمود (D ) 

 

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

ما تحكي كده من الصبح

Option Explicit
Sub New_Numeration()
Dim sh As Worksheet
Dim k%
 Set sh = Sheets("Data")
 k = 2
    With sh
          Do Until Range("d" & k) = ""
          Range("b" & k) = Application.CountIf(.Range("d2" & ":d" & k), .Range("d" & k))
          k = k + 1
        Loop
     End With
End Sub

 

[ابو حمادة]

الان, سليم حاصبيا said:

ما تحكي كده من الصبح

Option Explicit
Sub New_Numeration()
Dim sh As Worksheet
Dim k%
 Set sh = Sheets("Data")
 k = 2
    With sh
          Do Until Range("d" & k) = ""
          Range("b" & k) = Application.CountIf(.Range("d2" & ":d" & k), .Range("d" & k))
          k = k + 1
        Loop
     End With
End Sub

 

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

بس لو   امكن اضافه بحيث يكون العمل ااخر مدى فيه بيانات في العمود (D)  علما بانه بعض الصفوف بتكون فارغه ليس بها بيانات

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

6 دقائق مضت, ابو حمادة said:

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

بس لو   امكن اضافه بحيث يكون العمل ااخر مدى فيه بيانات في العمود (D)  علما بانه بعض الصفوف بتكون فارغه ليس بها بيانات

Option Explicit
Sub New_Numeration1()
Dim sh As Worksheet
Dim k%, lr%
 Set sh = Sheets("Data")
  lr = sh.Cells(Rows.Count, 4).End(3).Row
  sh.Range("b2:b" & lr).ClearContents
 k = 2
    With sh
          Do Until k > lr
          If Range("d" & k) <> "" Then _
                    Range("b" & k) = Application.CountIf(.Range("d2" & ":d" & k), .Range("d" & k))
          k = k + 1
        Loop
     End With
End Sub

 

[ابو حمادة]

الان, سليم حاصبيا said:

ما تحكي كده من الصبح

Option Explicit
Sub New_Numeration()
Dim sh As Worksheet
Dim k%
 Set sh = Sheets("Data")
 k = 2
    With sh
          Do Until Range("d" & k) = ""
          Range("b" & k) = Application.CountIf(.Range("d2" & ":d" & k), .Range("d" & k))
          k = k + 1
        Loop
     End With
End Sub

 

يريت نفس الكوددا مع تعديل بسيط وهو ان الكود يوضع رقم مسلسل للكلمة الموجوده في الخليه (A1) 

يعني اذا تشابه الكلمه الموجوده في الخليه (A1) يتم وضع مسلسل لها ويترك باقي الكلمات فارغهه

انظر لهذه المعادله وحولها الى كود

 

=IF($D4=$A$1;MAX($B$2:B3)+1;"")

 

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

جرب هذا الكود

Option Explicit

Sub Numeration_by_seletion()
 Dim sh As Worksheet
 Dim My_Str$
 Dim lr%, k%, x%
 k = 1
 Set sh = Sheets("Data")
       With sh
                  My_Str = .[a1]
                   lr = .Cells(Rows.Count, 4).End(3).Row
                 .Range("b2:b" & lr).ClearContents
                 
                  If My_Str = vbNullString Then MsgBox "the cell $A$1 is Empty ": Exit Sub
                  
                  If Not (Application.CountIf(.Range("d2:d" & lr), My_Str)) Then _
                          MsgBox "The cell $A$1 with value : " & My_Str & Chr(10) & _
                         " Not exists in the range": Exit Sub
                  
                                  For x = 2 To lr
                                        With .Range("d" & x): If .Value = My_Str Then _
                                        .Offset(0, -2) = k: k = k + 1
                                        End With
                                  Next
        End With
  End Sub