اذهب الي المحتوي
أوفيسنا

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

قام بنشر (معدل)

السلام عليكم اخوانى الاجلاء

ومساكم الله بالخير 

أبحث عن كود لتسيق تلقائى لجميع ورقات العمل اعتمادا على الصفحة الرئيسية

لدىّ ملف مكون من 10 شيتات جميعهم بنفس التنسيق 

ماأريده هنا مع تغير تنسيق الورقة الرئيسية " sheet1 "

من تغييرنوع الخط وسمك الخط وطول وعرض الصفوف والاعمدة

يتم التغيير تلقائيا  بباقى شيتات الملف

دمتم فى امان الله وشكرا جزيلا 

تنسيق تلقائى.xlsb.rar

تم تعديل بواسطه رضا راغب
قام بنشر

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

أخي الكريم رضا، لأجل هذا الغرض تم إضافة كود في حدث WORKBOOK والذي يتم تنفيذه تلقائيا بمجرد الانتقال لأي شيت في المصنف (الملف)... أرجو أن يكون في الملف المرفق بعض المطلوب...

بن علية

تنسيق تلقائى.xlsb.rar

  • Like 2
قام بنشر

السلام عليكم

وهذا كود اخر اضافة الى حل الاستاذ الفاضل بن عليه

يقوم بأخذ تنسيقات الورقة الرئيسيه من عرض للاعمد والصفوف

والخط والبوردر

Sub Formt_Ali()
Dim Sht As Worksheet
Dim Sh As Worksheet
Dim Rw&, Col$
Set Sht = Sheets("الرئيسية")
With Application
     .ScreenUpdating = False
     .EnableEvents = True
With Sht
Rw = Split(.UsedRange.Address, "$")(4): Col = Split(.UsedRange.Address, "$")(3)
.Range("A1:" & Col & Rw).Copy
For Each Sh In Sheets
Ali_Wdth Sht, Sh, True, True
 If Not Sh.Name = .Name Then
    With Sh
       With .Range("A1:" & Col & Rw)
         .PasteSpecial xlPasteFormats
       End With
    End With
 End If
Next Sh
End With
    .CutCopyMode = False
    .ScreenUpdating = True
    .EnableEvents = False
End With
End Sub
Private Sub Ali_Wdth(ByVal Smp_Sht As Variant, ByVal Al_Sht As Variant, Optional Heights As Boolean = False, Optional Widths As Boolean = False)
  Dim Sc_Rn As Range, D_Rn As Range
  Dim R As Long, C As Long
  On Error GoTo Eri
  With Smp_Sht
    Set Sc_Rn = Range(.Cells(1, 1), .UsedRange.Cells(.UsedRange.Cells.Count))
  End With
  With Al_Sht
    Set D_Rn = Range(.Cells(1, 1), .UsedRange.Cells(.UsedRange.Cells.Count))
  End With
  R = WorksheetFunction.Max(Sc_Rn.Rows.Count, D_Rn.Rows.Count)
  C = WorksheetFunction.Max(Sc_Rn.Columns.Count, D_Rn.Columns.Count)
  Set Sc_Rn = Sc_Rn.Resize(R, C)
  Set D_Rn = D_Rn.Resize(R, C)
  If Heights Then
    For R = 1 To R
      D_Rn.Rows(R).RowHeight = Sc_Rn.Rows(R).RowHeight
    Next
  End If
  If Widths Then
    For C = 1 To C
      D_Rn.Columns(C).ColumnWidth = Sc_Rn.Columns(C).ColumnWidth
    Next
  End If
Eri:
End Sub

 

  • Like 3
قام بنشر (معدل)

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

أخي الكريم بن عليه

تحية الله عليك

أحسنت أحسنت 

والله ياأخى هذا هو المطلوب

بارك الله فيك وشكرا جزيلا 

دمتم فى رعاية الله

 

تم تعديل بواسطه رضا راغب
قام بنشر

أخى الكريم بن عليه

بارك الله فيك 

والله ماقصرت أحببت أن أبدى إعجابى بمشاركة الطيبة

فعلى مايبدو وكونى حديث العهد بالمنتدى فلن يسمح لى بذلك

اسمح ان اشكرك وابدى اعجابى لشخصكم الكريم

واتوجه للشكر لاخى الفاضل العيدروس

دمتم فى رعاية الله

قام بنشر

أخى الكريم بن عليه

عذرا اخى كيف يمكن إستثناء الشيت الاول والثانى

على اعتبار انهم خارج التنسيق التلقائى لاحتوائهم على بيانات ثابته

دمتم فى امان الله وشكرا جزيلا

قام بنشر (معدل)

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

أخي الكريم رضا، في هذه الحالة يجب إضافة أمر للكود باستعمال الدالة IF فيه نقوم باستثناء الشيت الأول والثاني أو غيرهما (بأسمائها) كما فعلت في الكود المعدل في الملف المرفق... أرجو أن تصل الفكرة...

أخوك بن علية

 

تنسيق تلقائى.rar

تم تعديل بواسطه بن علية حاجي
  • Like 1
قام بنشر

السلام عليكم أستاذنا المحترم

كود رائع تم نسخ الورقة الأولى ثم لصق التنسيق في الصفحات التي يتم فتحها

جزاكم الله خيراً...وإلى المزيد من التقدم والعطاء..

ما شاء الله بارك الله..

والسلام عليكم.

قام بنشر (معدل)

أخى الكريم بن عليه

اشكرك شكرا جزيلا

المقصود بإستثناء الشيت الاول والثانى موضح بالملف

حيث أن الشيتين يحتويا على بيانات من خلالها يتم عمل قوائم منسدلة

وإلى طلب على إستحياء بالرابط 

http://www.officena.net/ib/topic/64486-طلب-إضافة-رسائل-على-كود-نقل-بيانات-كل-10-ثوانى/

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

دمتم فى امان الله 

تم تعديل بواسطه رضا راغب
قام بنشر (معدل)

أخى الكريم الاستاذ القدير بن عليه

السلام عليكم

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

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

على البيانات المدخلة وخاصة مع الانتقال من شيت لاخر

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Application.ScreenUpdating = False
  If ActiveSheet.Name <> "الرئيسية" And ActiveSheet.Name <> "Sheet1" Then
  If ActiveSheet.Name <> "الرئيسية" And ActiveSheet.Name <> "Sheet2" Then
    Sheets("الرئيسية").Cells.Copy
    On Error Resume Next
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats
    Range("A1").Select
  End If
    Application.CutCopyMode = False
Application.ScreenUpdating = True
  End If
End Sub

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

تم تعديل بواسطه رضا راغب

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.

×
×
  • اضف...

Important Information