كود لجمع تسلسل أرقام تحتوي على أحرف ثابته

[ابو تميم]

تحياتي لجميع العلماء والمشرفين الاعزاء

لدي ملف إكسل يحتوي على مجموعة من الأكواد وهذه الأكواد تحتوي على أرقام تسلسلية وأحرف كما يلي

CCR-001

CCR-002

وهكذا ...

المطلوب هو أنه للحصول على الكود الجديد يجب إضافة رقم 1 للكود الحالي ( آخر كود تم استخدامه ) ولكن هنا الكود يحتوي على أحرف ضمن الأرقام

كيف يمكننا جمع رقم 1 للرقم المتسلسل المجاور للأحرف في الكود

مرفقا ملف يوضح ذلك

مع الاحترام والتقدير لجهود علمائنا الأعزاء

كود لجمع تسلسل أرقام تحتوي على أحرف ثابته.rar

[أ / محمد صالح]

أخي الكريم أبي تميم

لعمل هذا التسلسل قم بالآتي:

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

="CCR-"&TEXT(ROW(A1),"000")

ثم قم بنسخ المعادلة لباقي الصفوف للحصول على التسلسل التالي

أتمنى أن يكون هذا هو المطلوب

[ابو تميم]

أخي الاستاذ محمد صالح

جربت المعادلة ولكنها لم تعمل معي هل يمكن تطبيقها على الملف في المشاركة الأصلية

علما أني اريد النتيجة تظهر دائما في نفس الخلية وهي B6

أي أن النتيجة وهي الكود الجديد يجب أن يكتب تلقائيا في الخلية D6

ولك جزيل الشكر

تم تعديل مارس 1, 2012 بواسطه ابو تميم

[ابو تميم]

أرفق أليكم الملف مرة أخرة مع بعض التعديل على الجدول

الجدول يحتوي على مجموعة متسلسلة من الأرقام والمطلوب هو عند الضغط على كود جديد

يظهر عندي في الخلية D6 الكود الجديد حسب المعادلة

كود لجمع تسلسل أرقام تحتوي على أحرف ثابته.rar

[أ / محمد صالح]

تفضل أخي الكريم

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

ثم قم بربطه بالزر الموجود في الشيت

Sub newcode()

Dim oldtstr As String, newstr As String

oldstr = Range("B6").End(xlDown).Value

newstr = Mid(oldstr, 5) + 1

ActiveSheet.Range("d6").Value = Mid(oldstr, 1, 4) & Format(newstr, "000")

End Sub

ولكن أعتقد أنه ينقص شيء وهو إضافة الكود الجديد لقائمة الأرقام الحالية في حالة ما إذا تم استعماله

[بن علية حاجي]

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

أخي الكريم، حسب الطلب جرّب الكود التالي:

Sub test()

   [D6] = "CCR-" & Format(Application.WorksheetFunction.Substitute([B6], "CCR-", "") + 1, "000")

End Sub

أخوك بن علية

[ابو تميم]

شكرا للجميع على تعاونهم

في الحقيقة كود الأخ الاستاذ محمد صالح ممتاز جدا لأنه يعمل بشكل عام أي أنه في حال تم تغيير الأحرف فإنه يعمل على القائمة المحددة له فإنه يعمل عليها بشكل ممتاز جدا

جزاك الله خيرا أخي الاستاذ محمد صالح

جزاكم الله خيرا الأساتذة الذين ساعدوا في الاجابة لكم كل الاحترام والتقدير

انتهى السؤال وتمت الاجابة

[رجب جاويش]

السلام عليكم

هذا حل آخر عن طريق معادلة تعمل نفس عمل كود الأستاذ محمد صالح حتى فى حالة تغيير أحرف الكود

حل اخر.rar

[عبدالله المجرب]

السلام عليكم

بعد اذن الاساتذة الكرام واثراءً للموضوع

هذا الكود يقوم بنفس عمل اكواد ومعادلات الاخوة الكرام في الحلول السابقة لكن

يمتاز بانه لن يتاثر بعدد الاحرف (مرن)

Sub Abu_Ahmed()

LR = [b1000].End(xlUp)

[d6] = Mid(LR, 1, InStr(LR, "-")) & Format(Val(Mid(LR, InStr(LR, "-") + 1, 5)) + 1, "000")

End Sub

[أ / محمد صالح]

ما شاء الله

نعم التعاون على البر والتقوى

ربنا يوفق الجميع للخير

في الدنيا والآخرة

[ابو تميم]

روعة يا علماء الاكسل

سلمت أناملكم الذهبية

فعلا كل كود أروع من الآخر وجميعها مذهلة جدا

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

[الـعيدروس]

السلام عليكم

حقيقة أكواد قمة الروعة

وهكذا في حدث االصفحة

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, [B6]) Is Nothing Then

			  ALI_C = Target.Value

			  If Len(ALI_C) > 0 Then

			  S = Mid(ALI_C, 1, 6)

			  Z = S & Z + 1 + Right(ALI_C, 2)

			  End If

			  Application.EnableEvents = False

			  Target.Offset(0, 2).Value = Z

			  Application.EnableEvents = True

End If

End Sub