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

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

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

لا أحب ان أعمل على المصفوفات في عمليات الترحيل
يمكن اذا اردت هذا الماكرو
بعد ضبط وضع الجدول (بدون خلايا مدمجة)
اضافة صف فارغ رقم 5 (مخفي) وعامود فارغ "C"(يمكن اخفاءه)
لكن تركته حتى ترينه

  Sub My_tarhil()
   Dim Rsd As Worksheet
   Dim Sh As Worksheet
   Dim i%, m%
   Set Rsd = Sheets("الرصد")
   Set Sh = Sheets("الشيت")
  i = 7: m = 6
  Do Until Rsd.Cells(i, 4) = vbNullString
      Sh.Cells(m, 5).Resize(, 20).Value = _
      Rsd.Cells(i, 4).Resize(, 20).Value
      
      Sh.Cells(m, "y").Resize(, 5).Value = _
      Rsd.Cells(i, "y").Resize(, 5).Value
      
      Sh.Cells(m, "A").Resize(, 3).Value = _
      Rsd.Cells(i, "A").Resize(, 3).Value
  m = m + 4
  i = i + 1
  Loop
  End Sub

الملف مرفق

تسلم استاذ سليم.... هل من تعديل استاذنا في الكود اللي رفعته قبل ذلك...
باستخدام المصفوفات.. بحيث يبقى تمام... ومش لازم وجود خلايا مدمجه عادي؟؟؟؟
وهل حضرتك استخدام المصفوفات في الترحيل خطآ ..... ام ماذا؟؟؟؟

وهل حضرتك استخدام المصفوفات في الترحيل خطآ ..... ام ماذا؟؟؟؟[/quote]
استخدام المصفوفات في الترحيل ليس خطأ
لكن تصوري اننا نبحث عن مجموعة بيانات لنضعها في مصفوفة
و عند اكتمال المصفوفة نقوم بوضعها في المكان المناسب في الشيت المناسب
فلماذا لا نقوم بوضع ما نفتش عنه رأساً في المكان المناسب
دون المرور بالمصفوفة

لكن المصفوفه اسرع بكثير مع كثرة البيانات.....
هل من تعديل على الكود بالمصفوفه جزاك الله خيرا....
لان في فراغات الكود بيتجاهلها

هل ممكن حضرتك ترحل عمود واحد فقط كمثال توضيحي..وليكن ماده ٣....باستخدام المصفوفه كمثال...ونا أن شاء الله اكمل الباقي..
والله المستعان.

ربما تريدين هذا الكود( التنفيذ في صفحة new_sheet)
مصفوفات مع خلايا مدمجة

Option Explicit

 Sub By_array()
   Dim Rsd As Worksheet
   Dim NW As Worksheet
   Dim Rg_to_copy As Range
   Dim A
   Dim i%, m%, x%, y%, t%
   
   Set Rsd = Sheets("الرصد")
   Set NW = Sheets("New_sheet")
   
   Application.ScreenUpdating = False
   If NW.Range("A6").CurrentRegion.Rows.Count > 1 Then
    NW.Range("A6").CurrentRegion.Offset(1). _
    Resize(NW.Range("A6").CurrentRegion.Rows.Count - 1).Clear
   End If
  Set Rg_to_copy = Rsd.Range("A6").CurrentRegion
  If Rg_to_copy.Rows.Count = 1 Then GoTo Au_Revoir
  Set Rg_to_copy = Rg_to_copy.Offset(1).Resize(Rg_to_copy.Rows.Count - 1)
A = Rg_to_copy
m = 7
For x = 1 To UBound(A)
      For y = 1 To UBound(A, 2)
       NW.Cells(m, 1).Offset(, y - 1) = A(x, y)
      Next y
      
      For t = 1 To 3
       NW.Cells(m, t).Resize(4).Merge
      Next t
       
       NW.Cells(m, 4).Resize(, UBound(A, 2) - 3). _
       Interior.ColorIndex = 35
 m = m + 4
Next x
If NW.Range("A6").CurrentRegion.Rows.Count > 1 Then
  With NW.Range("A6").CurrentRegion.Offset(1). _
      Resize(NW.Range("A6").CurrentRegion.Rows.Count - 1)
    .VerticalAlignment = 2: .HorizontalAlignment = 3
    .Borders.LineStyle = 1
    .Font.Bold = True: .Font.Size = 14
  End With
End If
Au_Revoir:
Application.ScreenUpdating = True
  End Sub

ربما يكون هذا الملف اكثر جمالاً من حيث التنسيق

جزاك الله خيرا استاذ سليم...
ممكن من فضلك عمود واحد فقط يتم ترحيله كمثال...لان الكود عند دراسته صعب اعدل عليه..
استاذن حضرتك عمود واحد فقط كمثال وليكن العمود(N)
عشان اقيس عليه

مثال عما تريدينه (العامود D)

Option Explicit
 Sub Only_One()
   Dim Rsd As Worksheet
   Dim NW As Worksheet
   Dim Rg_to_copy As Range
   Dim A, shp As Shape
   Dim i%, m%, x%, y%, t%
   Dim max_ro%, Ld%
   Set Rsd = Sheets("الرصد")
   Set NW = Sheets("New_sheet")
   max_ro = Rsd.Cells(Rows.Count, "D").End(3).Row
   Application.ScreenUpdating = False
    NW.Range("A7").Resize(max_ro * 10, 30).Clear
   For Each shp In NW.Shapes
     If shp.Name Like "Red*" Then
     shp.Delete
  End If
   Next

A = Application.Transpose(Rsd.Range("D7:D" & max_ro))

m = 7
For x = 1 To UBound(A)
 NW.Cells(m, "D") = A(x)
 m = m + 4
 Next

If NW.Range("A6").CurrentRegion.Rows.Count > 1 Then
 Ld = NW.Cells(Rows.Count, "d").End(3).Row
  With Range("D7:d" & Ld).SpecialCells(2)
    .VerticalAlignment = 2: .HorizontalAlignment = 3
    .Borders.LineStyle = 1
    .Font.Bold = True: .Font.Size = 14
    .Select
My_RedBox
  End With
End If
NW.Range("D7").Select
Au_Revoir:
Application.ScreenUpdating = True
  End Sub
  '+++++++++++++++++++++++++++++
Sub My_RedBox()

Dim redBox As Shape
Dim Act_rg As Range
Dim p%
Dim NW As Worksheet
Set NW = Sheets("New_sheet")
 For Each Act_rg In Selection.Cells

   Set redBox = NW.Shapes.AddShape(msoShapeRectangle, _
        Act_rg.Left, Act_rg.Top, _
        Act_rg.Width, Act_rg.Height)
     With redBox
       .Line.ForeColor.RGB = RGB(255, 0, 0)
       .Line.Weight = 3
       .Fill.Visible = msoFalse
       .Name = "RedBox_" & p + 1
     End With
     p = p + 1
 Next

End Sub
'+++++++++++++++++++++++
Sub de_Red()
Dim shp As Shape
For Each shp In Sheets("New_sheet").Shapes
     If shp.Name Like "Red*" Then
     shp.Delete
     End If
  Next
End Sub

جزاك الله خيرا استاذ سليم...سلمت يداك
...لكن هل من حل في عدم مسح الخلايا الاخرى التي بالعمود(D(
بمعنى : لو تم وجود بيانات بين المربعات الحمراء تفضل كما هي ..والترحيل يكون للمربعات الحمراء فقط