انشاء شيتات واعادة تسمية الشيتات

[adil8888]

ارجو المساعدة في كتابة كود يعمل على انشاء اوراق عمل وتغير اسمائها استنادا الى قائمة بالاسماء في sheet1  في الملف المرفق change sheets name اني اواجه مشلكة في كتابة كود اعادة التسمية ... ولكم الشكر 

change sheets name.xlsx

[ابراهيم الحداد]

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

استخدم هذا الكود

Sub AddSheets()
Dim List As Range, C As Range
Dim Sh As Worksheet
Set List = Sheet1.Range("B4:B" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row)
On Error Resume Next
For Each C In List
If Len(Trim(C.Value)) > 0 Then
If Len(Worksheets(C.Value).Name) = 0 Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = C.Value
End If
End If

Next
End Sub

 

[Ali Mohamed Ali]

وعليكم السلام أستاذى لقد أبدعت حقا كود رائع بارك الله فيك

ولإثراء الموضوع هذا كود اخر-ولتفعيله:

من قائمة Devloper

ثم             Macros

وبعد ذلك تضغط على RUN

فيخرج لك مربع حوارى تكتب فيه الإسم الذى تريده أن يكون صفحة جديدة

change sheets name.xlsm

[koky_dar]

2 ساعات مضت, زيزو العجوز said:

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

استخدم هذا الكود

Sub AddSheets()
Dim List As Range, C As Range
Dim Sh As Worksheet
Set List = Sheet1.Range("B4:B" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row)
On Error Resume Next
For Each C In List
If Len(Trim(C.Value)) > 0 Then
If Len(Worksheets(C.Value).Name) = 0 Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = C.Value
End If
End If

Next
End Sub

 

بارك الله فيك أستاذنا الفاضل و زادك علماً ونفع بك 

أنا جربت الكود دا وشغال تمام

بس محتاج تعديل من حضرتك

دلوقتي انا عندي شيت وليكن بأسم ahmed فيه معادلات وتنسيقات 

عايز لما انفذ الكود بتاع حضرتك بدل ما ينشأ شيت جديد فارغ , ينشأ نسخة من شيت ahmed بنفس التنسيقات والمعادلات وبدون اي قيم

هل ينفع عمل ذلك ؟ 

ولك جزيل الشكر و التقدير .

[ابراهيم الحداد]

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

استبدل الكود السابق بهذا الكود

Sub AddSheets()
Dim List As Range, C As Range
Application.ScreenUpdating = False
Set List = Sheet1.Range("B4:B" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row)

On Error Resume Next
For Each C In List
If Len(Trim(C.Value)) > 0 Then
If Len(Worksheets(C.Value).Name) = 0 Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = C.Value
End If
End If
Next
Dim Sh As Worksheet, ws As Worksheet
Set Sh = Sheets("ahmed")
Sh.UsedRange.Copy
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> Sheets("Sheet1").Name Then
ws.Range("A1").PasteSpecial xlPasteFormats
ws.Range("A1").PasteSpecial xlPasteFormulas
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[koky_dar]

24 دقائق مضت, زيزو العجوز said:

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

استبدل الكود السابق بهذا الكود

Sub AddSheets()
Dim List As Range, C As Range
Application.ScreenUpdating = False
Set List = Sheet1.Range("B4:B" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row)

On Error Resume Next
For Each C In List
If Len(Trim(C.Value)) > 0 Then
If Len(Worksheets(C.Value).Name) = 0 Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = C.Value
End If
End If
Next
Dim Sh As Worksheet, ws As Worksheet
Set Sh = Sheets("ahmed")
Sh.UsedRange.Copy
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> Sheets("Sheet1").Name Then
ws.Range("A1").PasteSpecial xlPasteFormats
ws.Range("A1").PasteSpecial xlPasteFormulas
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

مشكوووووووووور بارك الله في حضرتك وزادك علماً

اشتغل بشكل اكثر من رائع

مساعدة اخيرة انا اسف اني بتقل علي حضرتك

ازاي اخلي الخلية C1 تحتوي علي اسم الشيت ؟ في كل شيت جديد من اللي هيتعمل !

[ابراهيم الحداد]

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

اضف هذا السطر قبل آخر   Next

ws.Range("C1").Value = ws.Name

 

[adil8888]

اخوتي الاعزاء شكرا لاهتمامكم 

استخدمت هذا الكود وتجاوزت المعضلة 

 

Sub add_sheets()
' add_sheets macro & sheets rename
Dim x As Integer
Dim myR As Variant
myR = ("k1:k369")
'we can chenge the range that we neded

For Each myR In Range("k1:k369")
 For x = 1 To 369
    Sheets("Sheet1").Select
    Sheets("Sheet1").Copy Before:=Sheets(1)
    Sheets("sheet1").Select
    myR.Select
    Selection.Copy
    Sheets("Sheet1 (2)").Name = myR(x)
    
   
    Next
 
 Next myR
End Sub