الترحيل من خلايا متفرقة باستخدام مصفوفة Transfer From Non-Adjacent Cells Using Array

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

أقدم لكم طريقة حصرية لترحيل الخلايا الغير متجاورة أو الخلايا المتفرقة وذكل بتخزين قيم الخلايا في مصفوفة.

بفرض أن لديك ورقة عمل Sheet1 بهذا الشكل

والمطلوب ترحيل الخلايا الملونة باللون الأصفر من ورقة العمل Sheet1 إلى ورقة العمل Sheet2 بالترتيب التالي 

(التاريخ - رقم الإيصال - اسم العميل - رقم التليفون - الإجمالي)

سنقوم بإنشاء مصفوفة باسم Arr لتحمل القيم لهذه الخلايا بالترتيب D7 (خلية التاريخ) ، ثم C5 (خلية رقم الإيصال) ، ثم B6 (خلية اسم العميل) ، ثم B7 (خلية رقم التليفون) ، ثم E15 (خلية الإجمالي)

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

يمكنك تطويع الكود بما يتناسب مع ملفك وهيكلة البيانات لديك.

وأخيراً إليكم الكود المستخدم في عملية الترحيل باستخدام المصفوفة

Sub TransferUsingArray()
    Dim Arr
    
    With Sheet1
        Arr = Array(.Range("D7"), .Range("C5"), .Range("B6"), .Range("B7"), .Range("E15"))
    End With
    
    With Sheet2
        .Range("B" & .Cells(Rows.Count, "B").End(xlUp).Row + 1).Resize(1, UBound(Arr) + 1).Value = Arr
    End With
    
    MsgBox "Done...", 64
End Sub

تحميل الملف من هنا

إعداد / ياسر خليل أبو البراء