دمج عمودين على التوالى

[ابو يحيى1]

اساتذتنا الكرام

كيف يمكن دمج بيانات عمودين على التوالى بمجرد انتهاء بيانات العمود الاول ( عدد صفوف الاعمدة غير ثابتة )

مع مراعاة ان بيانات العمود الثانى مجزأة ( بينها فراغات )

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

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

وشكراً على اهتمامكم 

 

دمج عمودين على التوالى.xlsx

[سليم حاصبيا]

جرب هذا الملف

Aobu_yehya.xlsx

[ابو يحيى1]

ما اروع الحلول لديك استاذنا سليم 

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

اعتذر مقدما على الاطالة 

هل يمكن تطوير الحل بحيث يشمل ان العمود الثانى غير متصل وبه فراغات 

وشكرا جزيلا

دمج عمودين على التوالى.xlsx

[مهندس الاكسل]

جرب المرفق

دمج عمودين على التوالى (1).xlsx

[سليم حاصبيا]

رائع و خقيقة مهندس

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

[مهندس الاكسل]

من بعدك أستاذنا
ومنكم نتعلم، وعلى خطاكم نسير

[ابو يحيى1]

ابداع اساتذتنا ومنه نتعلم

شكرا استاذنا مهندس الاكسل والشكر موصول لاستاذنا سليم

ولكن ظهرت بعض الصعوبة لدى تتمثل فى ----

اذا فرضنا ان محتوى العمودين ارقام وليست اسماء 

كيف يمكن جعل النتيجة تظهر عند الدمج مرتبه من الاصعر الى الاكبر 

دمج عمودين على التوالى (1).xlsx

[سليم حاصبيا]

في هذه الحالة الكود افضل ما يمكن

[سليم حاصبيا]

يمنكك تجربة هذا الملف (صفحة Salim)

Option Explicit
Sub All_in_One()
  Dim S As Worksheet
  Dim Rg_A As Range, Rg_D As Range
  Dim i%, m%, La%, LD%
  Dim Obj_Num As Object, Obj_Text As Object

Set S = Sheets("Salim")
S.Range("I2").Resize(1000).Clear
La = S.Cells(Rows.Count, 1).End(3).Row
LD = S.Cells(Rows.Count, 4).End(3).Row
Set Obj_Num = CreateObject("System.collections.Arraylist")
Set Obj_Text = CreateObject("System.collections.Arraylist")
 For i = 2 To La
  If S.Cells(i, 1) <> vbNullString Then
   If IsNumeric(S.Cells(i, 1)) Then
    Obj_Num.Add S.Cells(i, 1).Value
   Else
    Obj_Text.Add S.Cells(i, 1).Value
  End If
  End If
 Next
 '+++++++++++++++++++++++++++++
  For i = 2 To LD
  If S.Cells(i, 4) <> vbNullString Then
   If IsNumeric(S.Cells(i, 4)) Then
    Obj_Num.Add S.Cells(i, 4).Value
   Else
    Obj_Text.Add S.Cells(i, 4).Value
   End If
  End If
 Next
 If Obj_Num.Count Then
   Obj_Num.Sort
  End If
  If Obj_Text.Count Then
   Obj_Text.Sort
  End If
  m = 2
  If Obj_Num.Count Then
    S.Cells(m, "i").Resize(Obj_Num.Count) = _
    Application.Transpose(Obj_Num.toarray)
   S.Range("I2").Resize(Obj_Num.Count) _
    .Interior.ColorIndex = 35
    m = m + Obj_Num.Count - 1
  End If
  If Obj_Text.Count Then
    S.Cells(m, "i").Resize(Obj_Text.Count) = _
    Application.Transpose(Obj_Text.toarray)
    S.Cells(m, "i").Resize(Obj_Text.Count) _
   .Interior.ColorIndex = 40
   m = m + Obj_Text.Count - 1
  End If
  With S.Range("i2").Resize(m - 1)
   .Borders.LineStyle = 1
   .Font.Size = 14: .Font.Bold = True
   .InsertIndent 1
   End With
  End Sub

الملف مرفق (الصفحة Salim)

 

ABOU_Yahya Two_in_One.xlsm

[ابو يحيى1]

جزيل الشكر لك استاذنا سليم 

وعذرا لكثرة استفساراتى فانا ازداد بها علما من اساتذتى الكرام 

وبالفعل حاولت استخدام دالة MINIFS بداخل معادلة صفيف 

لكنى لم افلح

فلك كل الشكر 

[مهندس الاكسل]

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

تحياتي 

دمج عمودين على التوالي مع ترتيب الارقام من الاصغر للأكبر.xlsx

[ابو يحيى1]

حل ذكى ومنتهى الروعة استاذنا مهندس الاكسل   👌 👍 💪💪

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