اضافة رقم جديد الى ارقام التليفونات

[عصام عبدالرحمن بو محمد]

السلام عليكم

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

اعاده الله على الامة الاسلامية بالخير واليمن والبركات

 

الموضوع عندى ملفات فيها ارقام تليفون ولقد تم اضافة رقم الى الارقام

 والمطلوب  معادلة او كود اضافة رقم الى شمال الارقام

علما بأن التليفونات ارقام مختلفة فهناك اضافة رقم 6 واخر 9 و الارضى 2

وايضا الملف الواحد  فيه اكثر من شيت ممكن 3 واخر 5 واخر 20 شيت واكثر

فهل من مساعدة 

مرفق ملف توضيحى

 

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

 

 

[جمال عبد السميع]

لايوجد مرفقات أخى

أين المرفق ؟

[عصام عبدالرحمن بو محمد]

جزاك الله خيرا سارفقه مرة اخرى

[عصام عبدالرحمن بو محمد]

هل ظهر في المرفقات

[عصام عبدالرحمن بو محمد]

هل ظهر في المرفقات

[جمال عبد السميع]

إضغط الملف أخى بإحدى برامج الضغط  مثل ( winrar ) ثم قم برفعة

[عصام عبدالرحمن بو محمد]

هذا هو الملف

Book1 no tel.rar

[طارق محمود]

السلام عليكم

وبعد إذن اخي جمال

وضعت بجوار كل مجموعة الرقم المضاف

ثم نسخت المجموعات مع الترتيب للورقة "س"  وسميت المجال هناك extt

وهكذا يمكنك حذف هذه المجموعات من هذه الورقة

 

وإعتمد الكود علي مقارنة بداية الرقم مع العمود الأول من المجال extt وباستخدام دالة Vlookup  إيجاد الرقم المضاف

 

هذا هو الكود

Function UMN(Mobile As Range) As String

    Dim Prefix As Integer

 Suffix = Right(Mobile, 5)
 Prefix = Left(Mobile, Len(Mobile) - 5)
If Left(Mobile, 1) = 8 Then Prefix = 8: Suffix = Right(Mobile, Len(Mobile) - 1)
    
m = WorksheetFunction.VLookup(Prefix, Range("extt"), 2, 0)
UMN = m & Prefix & Suffix

End Function

 

تفضل المرفق وبه الدالة مفعلة باللون الأحمر

 

Book1 no tel2.rar

[عصام عبدالرحمن بو محمد]

السلام عليكم

 

اشكرك كثيرا اخى الفاضل وجزاك الله خيرا وكل من ساهم فى الرد او حل 

والان ان باجرب على الملفات عندى وابدأ بملف به 100 الف رقم  

والمشكلة ان اى ملف لا يقل عن 50 الف رقم 

وان شاء الله  تضبط معى 

وان شاء الله يكون لنا رجعة ابلغكم بالنتيجة

 

واشكركم مرة اخرى

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

اخوكم عصام

 

     

[جمال عبد السميع]

بعد إذن أستاذى ومهندس المنتدى الرائع ( طارق محمود )

طبعا أنا أخذت على عاتقى إننى لن أتقدم بإى كود إلا إذا تحولت المعادلة معى لعمل المستحيل

وبصراحة أستاذى أكوادك ومعادلاتك شئ عبقرى بجد

ولكن أتمنى من حضرتك تقييم هذه المعادلة لأن فى إعتقادى إنها ممكن أن تحل مشاكل كثيرة يتعرض لها الكثيرين فى عملية إحلال أرقام بدل أرقام

لأن رأى حضرتك يهمنى بجد

إلى أخى ( VIVA ) هذه المعادلة بجانب كود أستاذى العبقرى ( طارق محمود )

 

 

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

Book1 no tel.rar

تم تعديل يونيو 8, 2013 بواسطه جمال عبد السميع

[جمال عبد السميع]

طريقة ثانية لكن أنا بفضل الأولى

 

TELERH-NO.rar

[طارق محمود]

السلام عليكم

أخي الحبيب / جمال

أنا أيضا لاألجأ للأكواد إلا إذا فشلت في المعادلات

ولكن إحترافي للمعادلات لايرقي لمستواك وصبري أيضا ليس كصبرك فغالبا ماأيأس وألجأ للكود

ولكني أشعر بسعادة بالغة إذا وجدت حلولا بالمعادلات

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

وأيضا المعادلة ليست بالغة التعقيد

وإن كانت طويلة نسبيا مما سيجعل الملف بطيئا إذا كان كما قال أخونا الفاضل عصام (السائل) : الملف به 100 الف رقم

 

لكنها تظل أجمل من الكود

[جمال عبد السميع]

أستاذى ومهندسنا الرائع ( طارق محمود ) شرف لية مرور حضرتك وكلماتك

وأنا معجب بحضرتك فى كافة الأحوال سواء أكان المقدم من حضرتك معادلات أوأكواد

لأن كلاهما مميز وذو بصمة خاصة لاتصدر إلا من عبقرى مثل حضرتك

جزاك الله خيرا أستاذى على تشجيعك ومرورك

[عصام عبدالرحمن بو محمد]

السلام عليكم 

اخى الفاضل الاستاذ الكبير طارق محمود

والاستاذ الفاضل الكبيرجمال عبدالسميع

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

ويمكن انا ضعيف فى الاكواد 

ولكن استفدت من خبراتكم كثيرا وكذلك اعجبنى طريقة الاستاذ جمال فى المعادلات فسهلت لى المهمة لقد قمت بنسخ المعادلة و ضبطت معى 

لان حاولت طوال امس ان استخدم الكود وكلما اعمل ران لا يعمل معى 

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

وسحبت الخلية فاضافت الارقام وهكذا حلت المشكلة

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

جزاكم الله خيرا وبارك الله فى مجهودكم

وافادكم الله وزادكم علما وجعله فى موازين حسناتكم والله مجهودكم رائع ومشاركتم افادتنى كثيرا لان لدى الكثير من الملفات التى احتاج لها الى تعديل

والحمد الله الان استطيع تعديل ملفاتى فى العمل 

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

فلقد ساعدتنى فى الملف الصعب عندما ارسلته لك على الايميل الخاص قبل 3 سنوات فى 2010  ونقل البيانات من ملف ورد الى ملف الاكسل فالاكواد هنا كانت الفيصل

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

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

فعندما قمت بتعديل الارقام وعمل فرز للملف بالاسماء ظهر لى اسماء مكررة مرة واثنين وثلاثة ولكن بارقام مختلفة لنفس الشخص 

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

لذلك ارسل لكم نموذج من الملف واصل الملف وانا قسمته الى الى اثنين شيت كل شيت فيه 34 الف والاخر 31 الف اسم 

ان شاء الله اجد الحل عندكم  لتكرار الاسماء

مرفق ملف

مع تحياتى لكم كثيرا

اخوكم عصام

 

     

 

تم تعديل يونيو 10, 2013 بواسطه vivazlata

[عصام عبدالرحمن بو محمد]

هذا هو الملف وارجو المساعدة

Numbers with adress tast.rar

[جمال عبد السميع]

فى عمود الأسماء إستخدم هذه المعادلة ستحقق لك المطلوب

ويمكن إستخدامها فى جانب الأرقام أيضا لوكان بها تكرار

ملحوظة : المعادلة معادلة صفيف أى لابد من الضغط على (CTRL+ SHIFT+ENTER ) لعمل هذان القوسان ( {  } )

=IF(ISERROR(INDEX($C$4:$C$28;MATCH(0;COUNTIF($F$3:F3;$C$4:$C$28);0)));"";INDEX($C$4:$C$28;MATCH(0;COUNTIF($F$3:F3;$C$4:$C$28);0)))

وأستخدم هذه لوكنت تستخدم 2007

=IFERROR(INDEX($C$4:$C$28;MATCH(0;COUNTIF($F$3:F3;$C$4:$C$28);0));"")

تقبل تحياتى : أخيك

تم تعديل يونيو 10, 2013 بواسطه جمال عبد السميع

[عصام عبدالرحمن بو محمد]

السلام عليكم 

اخى الفاضل جمال 

اشكرك على الرد 

انا استخدم اوفيس 2010

وجرب المعادلة الاولى وتظهر لى رسالة خطأ فى هذا الرمز   $C$28

وجربت على نفس الملف الذى ارسلته  لك

مع تحياتى لك 

[طارق محمود]

السلام عليكم

طبعا أذكرك جيدا أخي عصام

أهلا ومرحبا بك في أي وقت

 

بعد إذنكم جميعا

جرب الكود المرفق

Sub join_Repeted_data()
LR = [C9999].End(xlUp).Row
For r = 4 To LR
    nm = Cells(r, "C")
    For j = r + 1 To LR
        If Cells(j, "C") = nm Then
            LR = LR - 1
            Cells(j, "D").Copy Cells(r, "C").End(xlToRight).Offset(0, 1)
            Cells(j, "C").EntireRow.Delete
        End If
    Next j
Next rEnd Sub

بالملف التالي

يمكن تشغيل الكود بالضغط علي Ctrl-Shift-T

Numbers with adress tast.zip

[جمال عبد السميع]

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

أخى ( عصام ) إلى حضرتك الملف والمعادلة تعمل بشكل ممتاز

 

Numbers with adress tast.rar

[عصام عبدالرحمن بو محمد]

السلام عليكم

شرف لى معرفتك استاذى الكبير طارق 

وايضا استاذى الكبير جمال 

اشكركم على الحلول والان سوف اطبق على ملفاتى هذه الحلول وسوف اوافيكم بالنتيجة 

وخصوصا خوفى من كبر الملف كما ذكرت لكم سابقا 

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

اخوكم عصام

     

[عصام عبدالرحمن بو محمد]

السلام عليكم 

استاذى الفاضل المهندس طارق

والاخ الفاضل استاذ جمال

 

استاذى العزيز طارق 

لقد قمت بتجربة الكود وذلك بنسخ الكود وعندما اعمل ران يظهر لى هذه الرسالة   

comile error

syntax error

وهى تأتى بالسهم على الاسم

 

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

حاولت تغير الاسم تظهر عندى رسالة خطأ اخرى 

تعبت حقيقى وباءت محاولتى كلها بالفشل

 

 

والمشكلة الاخرى هى ان الاسم يكرر احيانا ثلاث مرات 

وكل مافى الملف يعمل على رقمان فقط

اى انى محتاج ثلاث ارقام بالعرض وليس اثنين فقط

ثانيا الملف عندى كبير الشيت الاول 34350 رقم اى صف والشيت الاخر 31190 رقم

وحاولت نسخ الاسماء والجدول فى الملف المرسل من قبلكم لا يعمل ويتوقف مع انى كنت حريص بعدم المساس بالمعادلة او تعديل اى شىء 

ولكن هناك اكيد خطأ منى فى عدم تحديث ارقام الخلية 

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

بس انا مش قادر اضبطه معى

لذلك ارجو منك كما فعلت معى سابقا انك قمت بعمل كود فى شيت A  وقلت لى فقط انسخ الداتا فى الخلية B وسوف يتحول الملف الى المطلوب 

وحقيقى كان رائع وسهل لى العملية معى 

وخصوصا انى عندى من هذا الملف 6 ملفات وبنفس العدد تقريبا 

فهل اطمع فى هذا منكم 

ام ما هو الحل لهذه المشكلة

مع تحياتى وشكرى لك ولمجهودك الرائع وعبقريتك فى الاكواد

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

هذا بالنسبة للكود

 

 

اما بالنسبة لاستاذ جمال جزاه الله خيرا 

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

ارجو الرجوع الى الملف المرفق من قبلكم

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

ارجو النظر فى الملف المرسل من طرفكم والنظر فى المعادلات 

فى انتظار ردكم الكريم وحلولكم الرائعة

 

مع تحياتى لك على المجهود المبذول منكم 

وشكرى وامتنانى لك بهذا

وجزاك الله خيرا على هذا المجهود الرائع منكم

اخوكم عصام

   

[طارق محمود]

السلام عليكم

المشكلة الأولي:

الخطأ :  compile error ، syntax error   قد ينتج عن أن المتغيرات التي استخدمتها أنا بالكود غير معرفة عندك

مثال في الكود السطر   LR = [C9999].End(xlUp).Row    يطلب من الاكسل اعطاء قيمة معينة للمتغير LR

فلابد من تعريف هذا المتغير قبل هذا السطر بعبارة  Dim LR As Integer مثلا

أو للهروب من ذلك فلايكون لديك السطر التالي في أول الأكواد  Option Explicit  كما أفعل أنا

فهذا السطر يجبر البرنامج علي رفض قبول متغيرات بدون تعريف مسبق لها

إبحث في محرر الأكواد لديك ستجده في حدث فتح الملف مثلا أو في أي مكان آخر ، إذا وجدته امسحه

أو عرف جميع المتغيرات (الثلاثة) في الكود بإضافة السطر التالي في البداية

Dim LR As Integer, r As Integer, j As Integer

 

المشكلة الثانية:

إستبدل العنوان C9999 الموجود في الكود بـ C65536 وهو عنوان أقصي سطر ممكن بالإكسل 2003

وحيث ان عدد البيانات عندك لايتجاوز هذا العدد

ولو الإكسل عندك 2007 أو 2010 يكون أفضل تجعل الملف بصيغة xlsb  أو xlsm وتجمع كل البيانات في شيت واحد

 

المشكلة الثالثة:

ستبدل الكود السابق بهذا

Sub join_Repeted_data()
Dim LR As Integer, r As Integer, j As Integer
LR = [C65536].End(xlUp).Row
For r = 4 To LR
    nm = Cells(r, "C")
    For j = r + 1 To LR
        If Cells(j, "C") = nm Then
            Cells(j, "D").Copy Cells(r, "C").End(xlToRight).Offset(0, 1)
            Cells(j, "C").EntireRow.Delete
            LR = LR - 1: j = j - 1
        End If
    Next j
Next r
End Sub

حيث تم استبدال  C9999  بـ C65536

وتم إضافة السطر

Dim LR As Integer, r As Integer, j As Integer

في أول الكود

 

وتم إضافة المعادلة j = j - 1

في السطر LR = LR - 1

ليصبح

LR = LR - 1: j = j - 1

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

ليس فقط 2 أو 3 بل أكثر

[عصام عبدالرحمن بو محمد]

السلام عليكم

اخى الفاضل المهندس طارق

تشكرك على مجهودك الرائع

وسوف اجرب الالكود الجديد

وانا عندى اكسل 2010

وسوغ اجمع الملف فى شيت واحد

واحفظه كما قلت

واجرب والله الموفق

واشكر جهودك معى

وجزاك الله خيرا على ما تساعد به الاخرين 

بارك الله فيك وفى جهودك

وزادك علما

مع تحياتى لك

عصام

   

[عصام عبدالرحمن بو محمد]

السلام عليكم

اخى الفاضل المهندس طارق

تحياتى لك

اولا قمت بعمل جمع للشيتين فى شيت واحد وفى ملف جديد

وقمت بحفظه xlsm  والداتا وصلت الى 65536 والعدد الاصلى عندى 65539 بالظبط ولكن فقط هذا اخر الشيت 65536

ثانيا قمت بنسخ الكود وعمل run  ثم ذهبت option وعملت key  = ctrl +shift + T  وعملت run مرة اخرى

ولكن عند التطبيق على الشيت  لايعمل الماكرو

هناك شىء انا لم افعله لتشغيل الكود

فارجو الافادة 

 

مع تحياتى 

اخوك عصام

     

[طارق محمود]

حيث أنك تعمل علي 2010 وبصيغة xlsm

فيمكنك ببساطة تغيير السطر

LR = [C65536].End(xlUp).Row

إلي

 LR = [C99999].End(xlUp).Row

وتنتهي المشكلة

هذا الرقم 99999 يعني رقم السطر اللي انت ضامن انه فاضي في آخر الشيت

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