احتاج لعمل شيتات باسماء من العمود A

[abouelhassan]

• السادة الافاضل

  هل بالامكان المساعدة فى عمل كود يقوم بعمل شيتات اسمائها من العمود a شيت اسماء الصفحات

  يعنى نضع اى اسماء بالعمود a وننفذ الكود فينشأ صفحات بنفس التنسيق لصفحة home ولكن اسم كل صفحة بالترتيب من العمود a شيت اسماء الصفحات

  مع خالص الشكر والتقدير

   

New Microsoft Excel Worksheet.xlsm

[الرائد77]

تفضل 

آسف لم انتبه الى التنسيق و المحتوى  في المشاركة الاولى

Sub AddWorksheetsR()
    Dim raedSheet As Worksheet
    Dim Source As Range
    Dim c As Range

    Set raedSheet = ActiveSheet
    Set Source = ActiveSheet.Range("a2:a100")
    Application.ScreenUpdating = False

    For Each c In Source
        RName = Trim(c.Text)
        If Len(RName) > 0 Then
                Worksheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = RName
                Sheets("home").Range("a:i").Copy
                ActiveSheet.Range("a:i").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
      ActiveSheet.Range("a:i").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

        End If
    Next c

    raedSheet.Activate
    Application.ScreenUpdating = True
End Sub

 

 

New Microsoft Excel Worksheet.xlsm

تم تعديل مايو 14, 2020 بواسطه الرائد77

[Ali Mohamed Ali]

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

Option Explicit

Sub creat_shett()
Dim i%, t, m%
Dim x%: x = Application.CountA(Sheets("اسماء الصفحات").Range("A:A")) + 1

For i = 3 To x

t = Sheets("اسماء الصفحات").Range("a" & i)
On Error Resume Next
m = Len(Sheets(t).Name)
On Error GoTo 0
   If m = 0 Then
'==========================================================='
   Sheets("Home").Copy After:=Sheets(Sheets.Count)
   With ActiveSheet
   .Name = Sheets("اسماء الصفحات").Range("a" & i)
   .Range("a1") = .Name
   End With
 '==========================================================='
  End If
  m = 0
    Next
  Sheets("اسماء الصفحات").Select
End Sub

 

Sheets List.xlsm

[abouelhassan]

أعزكم الله استاذ الرائد

الاستاذ على

الاستاذ سليم 

كل الشكر والتقدير والاحترام

بارك الله فيكم أساتذة