الخطوة الرابعة: بما أن النطاق المطلوب نسخ بياناته في أورق العمل ثابت وهو يبدأ من الخلية E5 وينتهي بالخلية W5 ، سنقوم بوضع سطر يقوم بنسخ النطاق ، ولنقوم بعملية النسخ نشير لورقة العمل المطلوب نسخ البيانات منها ، وستكون الإشارة واحدة لجميع أوراق العمل ، حيث تم استخدام المتغير ws ليعبر عن ورقة العمل في الحلقة التكرارية ، وبالطبع كما شرحنا فإن المتغير ws سيتغير في كل حلقة تكرارية
كما تلاحظين السطر في منتهى البساطة .. إشارة لورقة العمل ، يليها إشارة للنطاق ، يليها ما نريد فعله بالنطاق وهو هنا أن نقوم بنسخ النطاق
النطاق هنا في صف واحد والمطلوب عند وضع البيانات أن تكون البيانات رأسية وليس أفقية كما هو موجود في أوراق العمل وهنا يمكننا استخدام اللصق الخاص ، ونستخدم Transpose
ويمكن تسجيل ماكرو بهذه الخطوة لمعرفة كيف يتم النسخ من الصف ليكون كعمود
>> بشكل يدوي نقوم بنسخ النطاق ثم تحديد أي خلية ، ونقوم بعمل كليك يمين على الخلية ثم Paste Special ثم نحدد الخيارات كما بالصورة
نعود للكود ..
المطلوب الآن لصق البيانات التي تم نسخها من السطر السابق ، لذا أول خطوة هنا هو تحديد الخلية الهدف التي سيتم لصق البيانات بها
والخلية ستكون في ورقة العمل الأساسية لذا نقوم بوضع إشارة لورقة العمل الأساسية وهي sh ، يليها الخلية الهدف وللإشارة للخلية يمكن استخدام Cells وهذه تستخدم للإشارة للخلية باستخدام رقم الصف يليه رقم العمود
بما أن رقم الصف المطلوب لصق البيانات فيه هو الصف رقم 6 ، والعمود سيكون رقمه متغير حسب الحلقة التكرارية وكما وضحنا (المتغير c)
إذاً ستكون الإشارة بهذا الشكل
بعد أن أشرنا لورقة العمل الهدف والخلية الهدف .. يأتي السؤال: ماذا نريد أن نفعل بتلك الخلية؟
الإجابة نقوم بعمل لصق خاص ونستخدم الأمر PasteSpecial ، ولهذا الأمر عدة بارامترات ، لن نحتاج إلا إلى اثنين منهم
البارامتر الأول وهو
وهو خاص باللصق الخاص
والبارامتر الثاني وهو تحويل البيانات من شكل أفقي لشكل رأسي ويكون بهذا الشكل
المهم في نهاية المطاف سيكون السطر بهذا الشكل
sh.Cells(6, c).PasteSpecial Paste:=xlPasteValues, Transpose:=True
وها هو الكود في شكله النهائي
Rem Step 4
Sub Test()
Dim ws As Worksheet, sh As Worksheet, c As Long
Application.ScreenUpdating = False
Set sh = ThisWorkbook.Worksheets("Come")
c = 10
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> sh.Name Then
ws.Range("E5:W5").Copy
sh.Cells(6, c).PasteSpecial Paste:=xlPasteValues, Transpose:=True
c = c + 1
End If
Next ws
Application.ScreenUpdating = True
End Sub