بسم الله الرحمن الرحيم ادراج نطاق في خلية واحدة

[tokhy2000]

عندي عمود فيه بيانات وعايز اجمع البيانات اللي ف العامود كله ف خلية واحده ويفصل بين كل معلومة واللي بعدها علامة الناقص 
مع العلم ان عندي اكثر من ١٢٠٠٠ سطر يعني ماينفعش & وايضاً عايز لو ضفت اَي حاجه ف العمود تظهر اوتوماتيك ف الخلية

 

[خالد الرشيدى]

السلام عليكم

جرب الكود التالى 
 

Book1.rar

تم تعديل مايو 18, 2017 بواسطه خالد الرشيدى

[tokhy2000]

السلام عليكم استاذ خالد

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

انا جربتها بس عندي ملحوظتين :

1- ان انا محتم عليه اني استخدمها ع عمود واحد يعني بفرض ان عندي العمود A, B , C,... وعايز كل عمود ف خلية اعمل ايه

2- او لو عايز استخدم الكود على صف مثلا

3- النتيجة بتبدا ب علامة "-" وانا عايز النتيجة تبدا باول رقم

 

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

[خالد الرشيدى]

السلام عليكم

هذه الملاحظات جميعها يستدعي تغيير الاكواد المستخدمة ... فلا تدع الامر مفتوحاً هكذا ... ارسل ملف به امثله للحالات المختلفة التى تحتاجها للعمل عليها 

تقبل مرورى وتحياتى 

تم تعديل مايو 18, 2017 بواسطه خالد الرشيدى

[tokhy2000]

معلش يااستاذ خالد

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

ممكن تشيك عليه

Book1.rar

[خالد الرشيدى]

اخي الكريم جرب الكود التالى.. ضف في عدد الاعمده كما تشاء ..

Private Sub Worksheet_Change(ByVal Target As Range)

    On Error Resume Next
    '  اذا حدث وان تم تغيير قيم احد خلايا العمود الاول او الثاني او الثالث
    If Target.Column = 1 Or Target.Column = 2 Or Target.Column = 3 Then
        Dim Lr As Long, r As Variant
        ' هنا ايجاد رقم اخر صف به بيانات حيث العمود الذي توجد به الخليه التى تم تغيير قيمتها
        Lr = Cells(Rows.Count, Target.Column).End(xlUp).Row
        'Lr حلقه تكرارية للمرور على كافة صفوف هذا العمود بدءاً من الصف السسادس وحتى الصف الاخير
        For i = 6 To Lr
            'r تخزين قيم هذا الصف داخل المتغير
            r = r & Cells(i, Target.Column).Value & " "
        Next
        '  - الفصل بين قيم المتغير ب
        r = Join(Split(Trim(r)), " - ")
        ' اهنا وضع الناتج داخل الخلية الموجوده بالصف 5 والعمود الذي به الخليه التى تغيرت قيمتها
        ' +3
        ' وطبعاً ده متناسب مع هذا الملف وعليك التغيير بما يتناسب مع ملفك الاصلي
        Cells(5, Target.Column + 3) = r
    End If

End Sub

Book1.rar

 

ولكن اخر سطر بالكود سيتوجب عليك تعديله بما يتناسب مع ملفك الاصلي حيث :

 Cells(5, Target.Column + 3)

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

 Cells(5, 1 + 3)

مما يعني الخليه الموجوده بالصف الخامس والعمود رقم 4 ( 3 + 1 ) اى الخليه D5

تم تعديل مايو 18, 2017 بواسطه خالد الرشيدى

[tokhy2000]

استاذ خالد 

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

 

Employee.rar

[خالد الرشيدى]

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

Private Sub Worksheet_Change(ByVal Target As Range)

    On Error Resume Next
    If Target.Column <> 1 And Target.Column <> 2 And Target.Column <> 3 And Target.Column <> 4 Then
        Dim Lc As Long, r As Variant, i As Integer
        Lc = Cells(Target.Row, Columns.Count).End(xlToLeft).Column
        For i = 5 To Lc
            If Cells(Target.Row, i) <> "" Then
                r = r & Cells(Target.Row, i).Value & " "
            End If
        Next
        r = Join(Split(Trim(r)), " - ")
        Cells(Target.Row, 1) = r
    End If
    
End Sub

 

Employee.rar

[tokhy2000]

معلش هو ازاي الكود هيقرا ف A3 البيانات اللي ف الصف رقم 3

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

والحاجة التانية ان الخلية الفاضية ف يقراها فاضية يعني تبقى " -  - "

[خالد الرشيدى]

6 دقائق مضت, tokhy2000 said:

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

 

بالفعل هو ده الكود الى بيعمله !!!!  راجع الملف بشكل جيد

بالنسبه للجزئيه التانيه استبدل الكود بهذا الكود

Private Sub Worksheet_Change(ByVal Target As Range)

    On Error Resume Next
    If Target.Column <> 1 And Target.Column <> 2 And Target.Column <> 3 And Target.Column <> 4 Then
        Dim Lc As Long, r As Variant, i As Integer
        Lc = Cells(Target.Row, Columns.Count).End(xlToLeft).Column
        For i = 5 To Lc
            r = r & Cells(Target.Row, i).Value & " "
        Next
        r = Join(Split(Trim(r)), " - ")
        Cells(Target.Row, 1) = r
    End If

End Sub

 

تم تعديل مايو 18, 2017 بواسطه خالد الرشيدى

[tokhy2000]

8 دقائق مضت, خالد الرشيدى said:

بالفعل هو ده الكود الى بيعمله !!!!  راجع الملف بشكل جيد

بالنسبه للجزئيه التانيه استبدل الكود بهذا الكود

Private Sub Worksheet_Change(ByVal Target As Range)

    On Error Resume Next
    If Target.Column <> 1 And Target.Column <> 2 And Target.Column <> 3 And Target.Column <> 4 Then
        Dim Lc As Long, r As Variant, i As Integer
        Lc = Cells(Target.Row, Columns.Count).End(xlToLeft).Column
        For i = 5 To Lc
            r = r & Cells(Target.Row, i).Value & " "
        Next
        r = Join(Split(Trim(r)), " - ")
        Cells(Target.Row, 1) = r
    End If

End Sub

انا فعلا اسف ع تعبك بس انا مابشتغلش ماكرو كتير ومش راضيه تظبط معايا انا غيرت الكود وكل خلية بتقرا البيانات اللي ف الصف رقم 2 مش الصف اللي موجودة فية انا ارفقتلك الملف عشان تشوفه

 

Employee.rar

[خالد الرشيدى]

اخي الكريم 

الملف والكود يعمل بشكل دقيق تماماً 

راجع المرفق

Employee.rar

[tokhy2000]

انا باخد Copy من الخلية رقم  A2

حضرتك بتشغلة ازاي ف الخلية رقم A3

[خالد الرشيدى]

تنفيذ الكود يكون بتغيير احد القيم الموجوده بالصف  او اضافه قيمة جديده 

بحيث عند تحديث البيانات ينفذ الكود بشكل تلقائي

بمعني لو قمت بتغيير قيمة الخليه E3 تقع بالصف الثالث ومن ثم يتم التجميع في A3 ..

او قم بتغيير قيم العمود  E   او F    او    G   h  او ................ ولاحظ النتائج 

ويمكن جعل تنفيذ الكود من خلال زر لو اردت ذلك 

تم تعديل مايو 18, 2017 بواسطه خالد الرشيدى

[tokhy2000]

2 دقائق مضت, خالد الرشيدى said:

تنفيذ الكود يكون بتغيير احد القيم الموجوده بالصف  او اضافه قيمة جديده 

بمعني لو قمت بتغيير قيمة الخليه A3 تقع بالصف الثالث ومن ثم يتم التجميع في A3 ..

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

[خالد الرشيدى]

اخي الكريم 

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

اما من خلال زر ( ولكن لو قمت بتغيير احد البيانات عليك الضغط على الزر لعمل تحديث لعمليه التجميع )

او من خلال ان تحدد له نطاق بحيث اى تغيير في النطاق ينفذ الكود ( ودى هى الحاله بتاعتنا )  

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

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

وهذا كل ما استطيع تقديمة

Employee.rar

تم تعديل مايو 18, 2017 بواسطه خالد الرشيدى

[tokhy2000]

13 دقائق مضت, خالد الرشيدى said:

اخي الكريم 

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

اما من خلال زر ( ولكن لو قمت بتغيير احد البيانات عليك الضغط على الزر لعمل تحديث لعمليه التجميع )

او من خلال ان تحدد له نطاق بحيث اى تغيير في النطاق ينفذ الكود ( ودى هى الحاله بتاعتنا )  

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

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

 

Employee.rar

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

tafkit.rar

[خالد الرشيدى]

اخي الكريم 

حقيقة عدم التوضيح جعل الامر يأخذ اكثر من حقه .. وقدمت العديييييد من الطرق والاكواد وكلها اخذت وقت وجهد كبير

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

اطلب داله معرفة UdF 

تقبل تحياتى 

[tokhy2000]

3 دقائق مضت, خالد الرشيدى said:

اخي الكريم 

حقيقة عدم التوضيح جعل الامر يأخذ اكثر من حقه .. وقدمت العديييييد من الطرق والاكواد وكلها اخذت وقت وجهد كبير

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

اطلب داله معرفة UdF 

تقبل تحياتى 

اسف جدا برجاء اقبل اعتذاري

تم تعديل مايو 18, 2017 بواسطه tokhy2000

[خالد الرشيدى]

لا عليك اخى الكريم

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

تقبل مرورى وتحياتى