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

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


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

ارجو المساعدة في كتابة كود يعمل على انشاء اوراق عمل وتغير اسمائها استنادا الى قائمة بالاسماء في 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

 

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

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

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

من قائمة Devloper

ثم             Macros

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

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

change sheets name.xlsm

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

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

 

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

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 تحتوي علي اسم الشيت ؟ في كل شيت جديد من اللي هيتعمل !

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

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

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

 

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

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

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