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

[القول المأثور]

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

 

لدي ملف أكسل وبه عمود قمت بترتيبه حسب رغبتي، وأريد ترتيب عمود أخر مختلف به نفس البيانات بنفس العمود الذي قمت بترتيبه برغبتي، كيف يتم ذلك؟؟

 

مرفق: ملف أكسل، الشيت رقم 1 هو العمود الأساسي الذي يبنى عليه ترتيب البيانات والشيت رقم 2 المراد ترتيبه حسب ترتيب البيانات الشيت رقم 1

 

ملاحظة: في حالة وجود بيانات إضافية في العمود المراد ترتيبه يضاف ضمن القائمة وتوضع البيانات الاضافية في أخر سطر بعد الفرز حسب العمود الأساسي ولا يتجاهله.

مثال على الملاحظة حسب الصورة أدناه:

 

مع الشكر..

ترتيب بيانات الصفوف حسب القائمة الأساسية.xlsx

[Ali Mohamed Ali]

وعليكم السلام - تفضل

الم تطلع على الملف تم تنفيذ المطلوب بهذا الكود

Sub arrange()
Sheet1.Activate
    Columns("A:A").Select
    Selection.Copy
    Sheet2.Activate
    Columns("b:b").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub

 

 

ترتيب بيانات الصفوف حسب القائمة الأساسية.xlsm

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

بعد اذن الاخ علي 

جرب هذا الكود

Option Explicit
Sub Salim()
Dim My_rg1 As Range, RO%, m%, n%, x%
Dim Arr1, Ful_arr(), Arr2()
Set My_rg1 = Range(Sheets(1).Range("A4"), Sheets(1).Range("A4").End(4))
Arr1 = Application.Transpose(My_rg1)
RO = Sheets(2).Cells(Rows.Count, 1).End(3).Row
Sheets(2).Range("C4").CurrentRegion.Clear
m = 1: n = 1
For x = 4 To RO
    If IsError(Application.Match(Sheets(2).Range("A" & x), Arr1, 0)) Then
      ReDim Preserve Arr2(1 To m)
      Arr2(m) = Sheets(2).Range("A" & x).Value
      m = m + 1
    Else
      ReDim Preserve Ful_arr(1 To n)
      Ful_arr(n) = Sheets(2).Range("A" & x).Value
      n = n + 1
    End If
 Next
 With Sheets(2).Range("C4").Resize(n - 1)
   .Value = Application.Transpose(Ful_arr)
   .Borders.LineStyle = 1
   .Interior.ColorIndex = 20
   .Font.Bold = True
   .Font.Size = 14
   .InsertIndent 1
   If m <> 1 Then
        With .Offset(n - 1).Resize(m - 1)
         .Value = Application.Transpose(Arr2)
         .Borders.LineStyle = 1
         .Interior.ColorIndex = 19
         .Font.Bold = True
         .Font.Size = 14
         .InsertIndent 1
        End With
   End If
 End With
   Erase Arr1: Erase Ful_arr(): Erase Arr2()
End Sub

الملف مرفق

 

Tartib.xlsm

[القول المأثور]

شاكر لكم اهتمامكم ، الأخ علي محمد والأخ سليم حاصبيا،

تم حل المشكلة، ولكن أشكل علي أمر أخر يتعلق بنفس الفكرة المطلوبة في موضوعي..

وهي إذا أردت ترتيب قائمة عمود مبعثر وبه بيانات أعمدة مرتبطة به، وأريد ترتيبها حسب ترتيب القائمة في العمود الذي أرغب به، مع اضافة باقي الأعمدة المرتبطة به، كيف يتم ذلك؟

 

مرفق ملف أكسل الشارح لذاته. وجزيتم خيراً..

نموذج فرز حسب القائمة الأساسية.xlsx

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

كان من المفروض ان تذكر المشاركة الثّانية رأساُ لعدم اهدار الوقت باشياء غير مدروسة

الكود

Option Explicit
Sub test()
Dim RgA As Range, RgC As Range
Dim Find_rg As Range, Rgl As Range
Dim Dic_Yes As Object
Dim m%, x%, R%, arr
Set RgA = Sheets(1).Range("A4", Range("A3").End(4))
Set RgC = Sheets(1).Range("C4", Range("C3").End(4))
'===========================
Set Rgl = Sheets(1).Range("L4").CurrentRegion
R = Rgl.Rows.Count
If R > 1 Then
 Rgl.Offset(1).Resize(R - 1).Clear
End If

'============================
Set Dic_Yes = CreateObject("Scripting.Dictionary")
 For x = 1 To RgA.Rows.Count
  Set Find_rg = RgC.Find(RgA.Cells(x), lookat:=1)
   If Not Find_rg Is Nothing Then
    R = Find_rg.Row
     arr = Sheets(1).Cells(R, 3).Resize(, 8).Value
     arr = Application.Transpose(Application.Transpose(arr))
     Dic_Yes.Add m, Join(arr, "*")
     m = m + 1
   End If
Next
For x = 0 To Dic_Yes.Count - 1
   Range("L" & x + 4).Resize(, 8).Value = Split(Dic_Yes.Item(x), "*")
Next
x = x + 4
 For m = 1 To RgC.Rows.Count
    If RgC.Cells(m).Interior.ColorIndex > 0 Then
      RgC.Cells(m).Resize(, 8).Copy Cells(x, "L")
      x = x + 1
    End If
 Next
 
 With Range("l4").Resize(x - 4, 8)
  .Value = .Value
  .Borders.LineStyle = 1
  .Font.Bold = True
  .Font.Size = 14
  .InsertIndent 1
 End With

Set RgA = Nothing: Set RgC = Nothing
Set Find_rg = Nothing: Set Rgl = Nothing
Set Dic_Yes = Nothing: Erase arr

End Sub

الملف

 

Farz.xlsm

[القول المأثور]

الأخ سليم حاصبيا أصبت المطلوب، جزاك الله خيراً وزادك علماً.

نعم، لم أنتبه لطلبي الثاني إلا متأخراً

شكراً جزيلا على المساعدة.

 

[القول المأثور]

اخي سليم، ارجو التعديل على المعادلة بحيث تكون البيانات غير المطابقة الذي أريد ترتيبه لا تستند على لون تظليل الخلية، لأني لا اعلم إذا كانت هناك بيانات مختلفة إلا بعد تطبيق الكود، وتظهر في أخر البيانات..

لاحظت لابد من تظليل الصف بالكامل غير المشابهة للعمود الاساسي لكي يظهر في اسفل القائمة وخلاف ذلك لا يظهر..

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

تم العمل كما تريد

الكود يلون الصفوف الغريبة اوتو ماتيكياً

Option Explicit
Sub test()
Dim RgA As Range, RgC As Range
Dim Find_rg As Range, Rgl As Range
Dim Dic_Yes As Object
Dim m%, x%, R%, arr
Set RgA = Sheets(1).Range("A4", Range("A3").End(4))
Set RgC = Sheets(1).Range("C4", Range("C3").End(4))
'===========================
Set Rgl = Sheets(1).Range("L4").CurrentRegion
R = Rgl.Rows.Count
If R > 1 Then
 Rgl.Offset(1).Resize(R - 1).Clear
End If

'============================
Set Dic_Yes = CreateObject("Scripting.Dictionary")
 For x = 1 To RgA.Rows.Count
  Set Find_rg = RgC.Find(RgA.Cells(x), lookat:=1)
   If Not Find_rg Is Nothing Then
    R = Find_rg.Row
     arr = Sheets(1).Cells(R, 3).Resize(, 8).Value
     arr = Application.Transpose(Application.Transpose(arr))
     Dic_Yes.Add m, Join(arr, "*")
     m = m + 1
   End If
Next
For x = 0 To Dic_Yes.Count - 1
   Range("L" & x + 4).Resize(, 8).Value = Split(Dic_Yes.Item(x), "*")
   Next
x = x + 4
 For m = 1 To RgC.Rows.Count
  If IsError(Application.Match(RgC.Cells(m), RgA, 0)) Then
      RgC.Cells(m).Resize(, 8).Copy Cells(x, "L")
      Cells(x, "L").Resize(, 8).Interior.Color = RGB(0, 204, 255)
      x = x + 1
  End If
 Next
 
 With Range("l4").Resize(x - 4, 8)
  .Value = .Value
  .Borders.LineStyle = 1
  .Font.Bold = True
  .Font.Size = 14
  .InsertIndent 1
 End With

Set RgA = Nothing: Set RgC = Nothing
Set Find_rg = Nothing: Set Rgl = Nothing
Set Dic_Yes = Nothing: Erase arr

End Sub

 

 

Farz1.xlsm

[القول المأثور]

عزيزي سليم حاصبيا، اكتمل المطلوب، جزاك الله خيراً ونفع الله بعلمك.

عزيزي سليم، عذرا، يوجد نقص أخر لم أنتبه له إلا الآن، ذكرته في مشاركاتي سابقاً.

يرجى مشاهدة الملف المرفق للتوضيح أكثر، لم يضف الكود البرمجي البيانات من القائمة الأساسية بشكل مرتب عند تجربته بشكل فعلي في عملي.

 

ترتيب البيانات حسب محتوى العمود الأساسي.xlsm

[القول المأثور]

للأهمية.

 

ترتيب البيانات حسب محتوى العمود الأساسي.xlsm

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

اين الأهمية و سؤالك مطروح منذ اكثر من 24 ساعة

جرب هذا الماكرو

Option Explicit

Sub New_macro()
If ActiveSheet.Name <> "Salim" Then Exit Sub
  Dim S As Worksheet
  Dim RgA As Range, RgC As Range, RgL As Range
  Dim m%, x%, R%, Ro%
  Dim Bol1 As Boolean

  Set S = Sheets("Salim")
  Set RgA = S.Range("A4", Range("A3").End(4))
  Set RgC = S.Range("C4", Range("C3").End(4))
  Set RgL = S.Range("L4").CurrentRegion

R = RgL.Rows.Count
    If R > 1 Then
      RgL.Offset(1).Resize(R - 1).Clear
    End If
RgA.Copy S.Range("L4")
x = 4
'===========================
Do Until S.Range("L" & x) = vbNullString
 Bol1 = IsError(Application.Match(S.Range("L" & x), RgC, 0))
  If Not Bol1 Then
   Ro = Application.Match(S.Range("L" & x), RgC, 0) + 3
   S.Range("L" & x).Resize(, 8).Value = _
   S.Range("C" & Ro).Resize(, 8).Value
 End If
x = x + 1
Loop
m = x: x = 4
Set RgL = S.Range("L4").CurrentRegion.Columns(1)

 Do Until S.Range("C" & x) = vbNullString
 Bol1 = IsError(Application.Match(S.Range("C" & x), RgL, 0))
  If Bol1 Then
  
  With S.Range("L" & m).Resize(, 8)
   .Value = S.Range("C" & x).Resize(, 8).Value
   .Interior.Color = RGB(0, 204, 255)
  End With
     m = m + 1
 End If
x = x + 1
Loop
With Range("L4").Resize(m - 4, 8)
  .Value = .Value
  .Borders.LineStyle = 1
  .Font.Bold = True
  .Font.Size = 14
  .InsertIndent 1
  .VerticalAlignment = 2
 End With
End Sub

 

 

New_Tartib.xlsm

[القول المأثور]

جزاك الله خيرا أخي سليم على المساعدة..