تعديل على كود ترحيل البيانات لترحيل تنسيق الصفحة

[yasse.w.2010]

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

هذا الكود للستاذ سليم وقد اخذته من احدى المشاركات 

ارجو عند ترحيل البيانات ترحل معه تنسيق الصفحة شيت ( البيان ) من الوان و تنسيق للشيت

شاكر لكم مجهودكم

بيان.xlsm

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

تصحيح الكود

Option Explicit
Dim i%, Lr%
Dim T As Worksheet
Dim Spes_sh As Worksheet
Dim Flter_rg As Range
Sub ADD_Sheets()
Set T = Sheets("بيان")
If T.AutoFilterMode Then T.Range("A8").AutoFilter
Lr = T.Cells(Rows.Count, 2).End(3).Row
If Lr < 2 Then Exit Sub
With T
    For i = 9 To Lr
        If Not Application.Evaluate("ISREF('" & _
         .Range("C" & i) & "'!A8)") Then
           Sheets.Add(, Sheets(Sheets.Count)).Name = _
         .Range("C" & i)
        End If
    Next
End With

End Sub
'+++++++++++++++++++++++++++
Sub transfer_data()
Application.ScreenUpdating = False
ADD_Sheets

 If Lr < 9 Then Exit Sub
 Set Flter_rg = T.Range("A8").CurrentRegion
For Each Spes_sh In Sheets
    If Spes_sh.Name = T.Name Or Spes_sh.Name = "Justify" Then
    Else
      Spes_sh.Range("A8").CurrentRegion.ClearContents
      Flter_rg.AutoFilter 3, Spes_sh.Name
      Flter_rg.SpecialCells(12).Copy
      Spes_sh.Range("A8").PasteSpecial (8)
      Spes_sh.Range("A8").PasteSpecial (xlPasteAll)
    End If
Next

   If T.AutoFilterMode Then T.Range("A8").AutoFilter
   T.Select
   With Application
     .ScreenUpdating = True
     .CutCopyMode = False
   End With
End Sub

 

Yasser_Filter.xlsm

[yasse.w.2010]

الف شكر لحضرتك يا استاذ سليم