اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


الردود الموصى بها

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

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

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

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

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

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

 

Book1.rar

تم تعديل بواسطه ناصرالمصرى
رابط هذا التعليق
شارك

اسماء الصفحات باللغة الأجنبية (ثم ما هذه الحجم الهائل للملف 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

  • Like 2
رابط هذا التعليق
شارك

  • 8 months later...

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • المتواجدين الان   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information