اذهب الي المحتوي
أوفيسنا

كود ترحيل الارقام المكررة


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

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

وبعد

كنت قد عرضت موضوع اطلب فيه عمل قاعدة لمشروع الخبز ومحاولة الحد من التزوير باخراج الارقام القومية المكررة

وجزى الله الاخوة المساعدين لي لاتمام العمل

الاستاذ/ جمال عبد السميع

الاستاذ / رجب جاويش

الاستاذ / سعيد بيرم

الاستاذ / ضاحي الغريب

ولمراجعة الموضوع على هذا الرابط

 

http://www.officena.net/ib/index.php?showtopic=47525

 

ولكن المشكلة 

ان الاعمال التي ارسلها الاخوة الفضلاء  ممتازة ولكن لمشرع لم يتم كتابة الاسماء

ولكن 

نحن قد انتهينا من العمل بالفعل و نريد اخراج الارقام المكررة   والطرق التي يتم معرفة الارقام بها سواء كانت بطريقة التلوين الشرطي لتلوين خلية الارقام المكررة صعبة في البحث عنها في وسط  35000 رقم .

ولهذا جائتني فكرة وهي ما جعلتني اكتب هذا الموضوع

الفكرة هي

الترحيل

بمعني اننا ممكن ان نكتب البيانات جميعها بشكل عادي ويتم بعدها ترحيل الارقام المكررة في ورقة أخرى فيسهل على ذلك جمع الاسماء المكررة في مكان واحد بدلاً من ان نقوم بالبحث عنها وسط  35000 اسم

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

ولقد تركتم لكم ملف مرفق لجزء من العمل ليتم التامل معه

ترحيل الارقام المكررة.rar

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

السلام عليكم


Option Explicit

Sub kh_mKRR()


Dim c As Integer
Dim Last As Long, R As Long, LR As Long
'''''''''''''''''''''''''''''
Last = ورقة1.Cells(Rows.Count, "A").End(xlUp).Row
'''''''''''''''''''''''''''''
Range("A2").Resize(Cells(Rows.Count, "A").End(xlUp).Row).EntireRow.Delete
'''''''''''''''''''''''''''''
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'''''''''''''''''''''''''''''

With ورقة1
    For R = 2 To Last
        If WorksheetFunction.CountIf(.Range("C2:C" & Last), CStr(.Cells(R, "c"))) > 1 Then
            LR = Cells(Rows.Count, "A").End(xlUp).Row + 1
            .Cells(R, "A").Resize(1, 7).Copy Cells(LR, "A")
        End If
    Next
End With

'''''''''''''''''''''''''''''
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'''''''''''''''''''''''''''''

End Sub

ترحيل الارقام المكررة.rar

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

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

كم سعادتي بين استاذين جليلين من اساتذة الاكسيل

استاذ الاساتذة / استاذ عبد الله باقشير

واستاذي الحبيب / استاذ رجب جاويش

فبارك الله فيكما وجعل الله اعمالكم في ميزان حسناتكم اللهم امين

وجزاكم الله خيراً علامة الاكسيل استاذ عبدالله على هذا الكود الرائع والمميز

بجد لا تعليق فمثلي لا يعلق على استاذ الاساتذة وعلامة الاكسيل.

واخيراً استغل انني بين استاذين واسال

كيف اعدل على هذا الكود لاغير من التنفيذ من عمود الى اخر بمعني ان التنفيذ هنا على العمود c _الرقم القومي _ فماذ لو اردت ان اجعل هذا الكود يتفاعل في مكان اخر مع عمود اخر وليكن لو اردت ان اخرج المكرر في الاسماء _ عمود b _  او اي عمود كــg او h او اي عمود

ثانياً : كيف اعدل على الكودليقوم بترحيل   نطاق اوسع للصف بدلا من هنا مثلا يرحل من  a: g اريد ان اجعله اكبر وليكن مثلا a: t او غيره .

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

واعذروني وانا اعلم انكم في غاية العون ومد اليد لمساعدة امثالى ممن لا يفقهون شى في مجال الاكسيل

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

فماذ لو اردت ان اجعل هذا الكود يتفاعل في مكان اخر مع عمود اخر وليكن لو اردت ان اخرج المكرر في الاسماء _ عمود b _  او اي عمود كــg او h او اي عمود

غير في هذا السطر العمود الذي تريد

If WorksheetFunction.CountIf(.Range("C2:C" & Last), CStr(.Cells(R, "c"))) > 1 Then
كيف اعدل على الكودليقوم بترحيل   نطاق اوسع للصف بدلا من هنا مثلا يرحل من  a: g اريد ان اجعله اكبر وليكن مثلا a: t او غيره .
.Cells(R, "A").Resize(1, 7)

من العمود a الى g

سبعة اعمدة

غير العدد سبعة الى اي عدد تريد

اذا غيرت الى 20  سيكون من العمود a الى t

 

تحياتي

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

  • 1 year later...

 

السلام عليكم

Option Explicit

Sub kh_mKRR()


Dim c As Integer
Dim Last As Long, R As Long, LR As Long
'''''''''''''''''''''''''''''
Last = ورقة1.Cells(Rows.Count, "A").End(xlUp).Row
'''''''''''''''''''''''''''''
Range("A2").Resize(Cells(Rows.Count, "A").End(xlUp).Row).EntireRow.Delete
'''''''''''''''''''''''''''''
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'''''''''''''''''''''''''''''

With ورقة1
    For R = 2 To Last
        If WorksheetFunction.CountIf(.Range("C2:C" & Last), CStr(.Cells(R, "c"))) > 1 Then
            LR = Cells(Rows.Count, "A").End(xlUp).Row + 1
            .Cells(R, "A").Resize(1, 7).Copy Cells(LR, "A")
        End If
    Next
End With

'''''''''''''''''''''''''''''
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'''''''''''''''''''''''''''''

End Sub

 

 

 

ممتاز جداً جداً ان شاء الله في ميزان حسناتك

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

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

اخى واستاذنا عبد الله باقشير

جزاء الله خيرا على اعمالك العظيمه

نسأل الله ان يزيدك من فضله وعلمه

تقبل تحياتى

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

ا / عبد الله

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

لسهولة المقارنة 

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

السلام عليكم  الاخ صلاح 

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

 

 

ترحيل 2.rar

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

ا / محمد

حضرتك جبت المكرر بناء على الاسماء

المطلوب اظهار اصحاب الارقام القومية المكررة حسب التكرار بالرقم القومى تحت بعض

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

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

 

جميل جدا هذا الكود ، يمكن أن نستفيد منه في تطبيقات كثيرة ، منها قوائم الصفوف

 

 

 

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

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

 

رائع يا ا / محمد

ربنا يخليك

اكثر من رائع و مفيد جدا

 

 

الشكر لله اولاً وبعد ذالك للاخوه الاساتذة بارك الله فيهم تعلمنا منهم ومازلنا نتعلم مهاراتهم

لهم منى كل التقدير والاحترام

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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

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

Important Information