ربط خلايا محددة فى خلية واحدة أو Join selection Cells

[مختار حسين محمود]

السلام عليكم أحبابى واخوانى فى المنتدى

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

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

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

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

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

الكود وعليه شرح بالعربية :

Sub JoinCells()

Dim Rng As Range, C As Range, FC As Range, SS As String, Rep As Integer

On Error Resume Next  ' فى حالة حدوث خطأ يتم تخطيه للنقطة التالية

'جعل المستخدم يعين أو يحدد الخلايا المراد ربطها
Set Rng = Application.InputBox(Prompt:="   Ctrl' لربط  الخلايا الغير متجاورة " & " استخدم المفتاح ", Title:="سلسلة الخلايا", Type:=8)
 
 If Rng Is Nothing Then         ' فى حالة عدم فى تحديد أى خلايا
 
     Rep = MsgBox("  ! تم الغاء عملية الربط ", vbQuestion + vbRetryCancel) ' رسالة
        
        If Rep = vbCancel Then                      ' فى حالة الغاء تحديد الخلايا
            On Error GoTo 0         ' فى حالة حدوث خطأ تتم العودة الى نقطة الصفر
            Exit Sub                                    ' و يتم الخروج من الاجراء
        Else                           ' اذا لم يلغى المستخدم عملية تحديد الخلايا
            Run "JoinCells"                           ' يتم اعادة الاجراء من جديد
        End If  ' انتهاء جملة الشرط
 
 End If    ' انتهاء جملة الشرط
 
 Set FC = Rng(1, 1)              ' اعتبار  أول خلية فى الخلايا المحددة كخلية رئيسية تتجمع فيها نصوص باقى الخلايا
 
 For Each C In Rng                                                         ' عمل لوب على كل الخلايا المراد ربطها
    SS = C                                                 ' اعتبار قيمة المتغير نصا و تساوى قيم الخلايا المحددة
    C.Clear                                                                                ' تفريغ محتوى الخلية
    FC = Trim(Replace(FC, FC, "") & " " & FC & " " & SS) 'استبدال المحتوى الأصلى لأول خلية بالنصوص التى فى الخلايا
 Next C

End Sub                                                          ' انتهاء الاجراء

وهذا هو المرفق

Join selection Cells .rar

وهذا شكل آخر للكود

Sub JoinCells()

 Dim Rng As Range
 Dim C As Range
 Dim FC As Range
 Dim StrStart As String

 Set Rng = Sheets("Sheet1").Range("C10,E10,G10,I10")
 Set FC = Sheets("Sheet1").Range("C4")  'مكان تجميع الخلايا
 
 For Each C In Rng
    StrStart = C
    C.ClearContents   'OR : Clear
    FC = Trim(Replace(FC, FC, "") & " " & FC & " " & StrStart)
 Next C

End Sub

وهذا مرفق على الشكل الثانى للكود

Join specific Cells mokhtar .rar

تم تعديل يوليو 31, 2015 بواسطه مختار حسين محمود

[ياسر خليل أبو البراء]

بسم الله ما شاء الله أخي الغالي المتميز مختار

تسلم الأيادي وتكيد الأعادي .. تسلم يا ابن بلادي

إليك زيادة في الخير .. دالة لدمج القيم في خلية واحدة ويمكنك تحديد نوع الفاصل بين القيم من خلال المعادلة

Public Function Concat(MyRange As Range, Optional myDelimiter As String)
'=Concat(C9:I14," ")
    Dim rCell As Range

    Application.Volatile

    For Each rCell In MyRange
        Concat = Concat & rCell & myDelimiter
    Next rCell

    If Len(myDelimiter) > 0 Then
        Concat = Application.WorksheetFunction.Trim(Left(Concat, Len(Concat) - Len(myDelimiter)))
    End If
End Function

تقبل تحياتي

[مختار حسين محمود]

أخى و أستاذى الغالى أباالبراء بارك الله فيك  

مشكور أستاذى  على الاضافة  الجميلة

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

[أبوبسمله]

اخى الغالى مختار مفتقدينك والله ان شاء الله تكون بخير

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

 

[numanawwad1]

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

دمج خلايا بواسطة دالة.rar