نسخ نطاقين من ورقة عمل الى ورقه أخرى بنفس التنسيقات

[ناصرالمصرى]

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

كيف يمكن نسخ نطاقين مختلفين من ورقة عمل الى ورقه أخرى بنفس التنسيقات

تحتوى ورقة البيانات فى المرفق على النطاق من العمود A الى العمود J

حيث أرغب فى نسخ نطاق العمود A من ورقة البيانات الى العمود A فى ورقة الهدف

ونطاق الأعمدة من العمود B الى العمود J من ورقة البيانات الى نطاق الأعمده من J الى العمود R فى ورقة الهدف

لمزيد من التوضيح يُرجى الإطلاع على المرفق التالى وجزاكم الله خير الجزاء

 

Book1.rar

تم تعديل مارس 17, 2021 بواسطه ناصرالمصرى

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

اسماء الصفحات باللغة الأجنبية (ثم ما هذه الحجم الهائل للملف 11.5 ميغا) تم تحجيمة الى 80 كيلو فقط

Option Explicit

Sub Form_To()
Dim F As Worksheet, W As Worksheet
Dim max_ro%, max_col%

Set F = Sheets("From")
Set W = Sheets("Where")
max_ro = F.Cells(Rows.Count, 1).End(3).Row
max_col = F.Cells(8, Columns.Count).End(1).Column

W.Cells(8, 1).Resize(max_ro - 7).Value = _
F.Cells(8, 1).Resize(max_ro - 7).Value

W.Cells(8, "j").Resize(max_ro - 7, max_col - 1).Value = _
F.Cells(8, 2).Resize(max_ro - 7, max_col - 1).Value

End Sub

Naser.xlsm

[ناصرالمصرى]

جزاكم الله خيرا أستاذى الفاضل

الكود يعمل بشكل جيد من حيث المبدأ ولكن بدون روؤس الأعمده

فضلا عن أنه لا ينسخ نفس التنسيقات من ورقة From " المصدر " الى ورقة Where " الهدف " 

كنوع الخط وحجم الخط وارتفاع الصف وعرض العمود وما إلى ذلك من التنسيقات

فكيف السبيل لتحقيق ذلك ؟

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

نعديل الكود (نفس النتسيق)

اكنب رؤوس الأعمدة التي تريدها في الصف رقم 8

Option Explicit

Sub Form_To()
Dim F As Worksheet, W As Worksheet
Dim max_ro%, max_col%

Set F = Sheets("From")
Set W = Sheets("Where")
max_ro = F.Cells(Rows.Count, 1).End(3).Row
max_col = F.Cells(8, Columns.Count).End(1).Column
With W.Cells(8, 1)
  .CurrentRegion.Clear
  .Offset(, 9).CurrentRegion.Clear
  
  
   F.Cells(8, 1).Resize(max_ro - 7).Copy
  .PasteSpecial
  
  F.Cells(8, 2).Resize(max_ro - 7, max_col - 1).Copy
  .Offset(, 9).PasteSpecial
End With
Application.CutCopyMode = False

End Sub

 

Naser_1.xlsm

[ناصرالمصرى]

جزاكم الله خيرا وبارك فيكم

بقيت نقطة التنسيقات لم تضبط بعد فهل من سبيل أخر

وافر تقديرى واحترامى

تم تعديل مارس 18, 2021 بواسطه ناصرالمصرى
خطأ إملائى

[هشام جودي]

السلام عليكم

عمل ممتاز جدا بورك فيكم