أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
هانى على ali mohamed ali-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة منع ادخال البيانات بعدة شروط اكسيل اسئله واجابات


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





ترقيم تلقائى

السلام عليكم الاستاذة الكرام اريد عمل ترقيم تلقائى سواء بالمعادلات او vba الترقيم منقسم الى قسمين قسم ترقيم للجدول نفسه ..


موضوع مغلق


subject icon تمت الإجابة ترقيم تلقائى
06-11-2020 01:12 مساء
احمد شريف
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-10-2019
رقم العضوية : 15301
المشاركات : 85
الجنس : ذكر
تاريخ الميلاد : 5-2-1973
يتابعهم : 0
يتابعونه : 0
قوة السمعة : 105
 offline 

السلام عليكم الاستاذة الكرام اريد عمل ترقيم تلقائى سواء بالمعادلات او vba 
الترقيم منقسم الى قسمين قسم ترقيم للجدول نفسه ومن ترقيم داخل الجدول نفسة الصراحة صعب الشرح بالكلام مرفق لحضرتكم الملف اعتقد انها فكرة جديدة لم يتم تناولها من قبل والله اعلم لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  ترقيم.xlsm   تحميل xlsm مرات التحميل :(13)
الحجم :(9.471) KB



أفضل إجابة مقدمة من YasserKhalil وهي:
وعليكم السلام أخي الكريم أحمد
جرب الكود التالي عله يفي بالغرض ..
الكود الأول يقوم بمسح البيانات الموجودة في العمود الأول في كل جدول مع مسح رقم الجدول ..
الكود الثاني يقوم بالترقيم بشكل تسلسلي لكل جدول ويكمل في الجدول الذي يليه ، مع فرض أن عدد صفوف كل جدول ثابتة (6 صفوف)
Sub Clear_Data_From_Tables()
    Dim r As Range, c As Range, rFirst As Range
    Set r = ActiveWorkbook.Worksheets("Sheet1").Range("A1:J100")
    Set c = r.Find("s", , , , xlByColumns)
    If rFirst Is Nothing Then Set rFirst = c
    Do While Not c Is Nothing
        c.Offset(1).Resize(6).ClearContents
        c.Offset(, 1).ClearContents
        Set c = r.FindNext(After:=c)
        If c.Address = rFirst.Address Then Exit Do
    Loop
End Sub

Sub Put_Sequence_To_Multiple_Tables_FindNext_Do_While_Loop()
    Dim w, r As Range, c As Range, rFirst As Range, m As Long, n As Long
    Set r = ActiveWorkbook.Worksheets("Sheet1").Range("A1:J100")
    m = 1: n = 1
    Set c = r.Find("s", , , , xlByColumns)
    If rFirst Is Nothing Then Set rFirst = c
    Do While Not c Is Nothing
        w = Evaluate("ROW(" & m & ":" & m + 5 & ")")
        c.Offset(1).Resize(UBound(w, 1)).Value = w
        c.Offset(, 1).Value = n
        m = m + 6: n = n + 1
        Set c = r.FindNext(After:=c)
        If c.Address = rFirst.Address Then Exit Do
    Loop
End Sub
عرض الإجابة




07-11-2020 09:56 صباحا
مشاهدة مشاركة منفردة [1]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10444
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36522
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif ترقيم تلقائى
وعليكم السلام أخي الكريم أحمد
جرب الكود التالي عله يفي بالغرض ..
الكود الأول يقوم بمسح البيانات الموجودة في العمود الأول في كل جدول مع مسح رقم الجدول ..
الكود الثاني يقوم بالترقيم بشكل تسلسلي لكل جدول ويكمل في الجدول الذي يليه ، مع فرض أن عدد صفوف كل جدول ثابتة (6 صفوف)
Sub Clear_Data_From_Tables()
    Dim r As Range, c As Range, rFirst As Range
    Set r = ActiveWorkbook.Worksheets("Sheet1").Range("A1:J100")
    Set c = r.Find("s", , , , xlByColumns)
    If rFirst Is Nothing Then Set rFirst = c
    Do While Not c Is Nothing
        c.Offset(1).Resize(6).ClearContents
        c.Offset(, 1).ClearContents
        Set c = r.FindNext(After:=c)
        If c.Address = rFirst.Address Then Exit Do
    Loop
End Sub

Sub Put_Sequence_To_Multiple_Tables_FindNext_Do_While_Loop()
    Dim w, r As Range, c As Range, rFirst As Range, m As Long, n As Long
    Set r = ActiveWorkbook.Worksheets("Sheet1").Range("A1:J100")
    m = 1: n = 1
    Set c = r.Find("s", , , , xlByColumns)
    If rFirst Is Nothing Then Set rFirst = c
    Do While Not c Is Nothing
        w = Evaluate("ROW(" & m & ":" & m + 5 & ")")
        c.Offset(1).Resize(UBound(w, 1)).Value = w
        c.Offset(, 1).Value = n
        m = m + 6: n = n + 1
        Set c = r.FindNext(After:=c)
        If c.Address = rFirst.Address Then Exit Do
    Loop
End Sub

07-11-2020 01:47 مساء
مشاهدة مشاركة منفردة [2]
احمد شريف
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-10-2019
رقم العضوية : 15301
المشاركات : 85
الجنس : ذكر
تاريخ الميلاد : 5-2-1973
يتابعهم : 0
يتابعونه : 0
قوة السمعة : 105
 offline 
look/images/icons/i1.gif ترقيم تلقائى
بسم الله ما شاء الله  الله اكبر حضرتك رهيب فعلا مهما اقول مش هقدر اوفى قدر حضرتك انا قدرت احل النصف الاول هو ترقيم الجدول ولكن ليس بهذا الابهار اللى حضرتك عملته اما الباقى فكان لى ضربا من المستحيل جزاك الله كل خير يا استاذ ياسر 

07-11-2020 02:01 مساء
مشاهدة مشاركة منفردة [3]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10444
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36522
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif ترقيم تلقائى
وجزيت خيراً أخي العزيز أحمد شريف ومشكور على كلماتك الطيبة
والحمد لله الذي بنعمته تتم الصالحات

07-11-2020 06:15 مساء
مشاهدة مشاركة منفردة [4]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10444
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36522
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif ترقيم تلقائى
تم نقل الموضوع لقسم إكسيل أسئلة وإجابات ... يرجى طرح السؤال في القسم المناسب



الكلمات الدلالية
ترقيم ، تلقائى ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 12:52 صباحا