Code For Copy Sheets In same File Workbook

[Mahmoud Atef]

السلام عليكم
الكود التالى وظيفة عمله

تحديد الخلايا التي تحتوي على الاسماء ومن ثم سيتم عمل شيتات بنفس الأسماء الموجودة فى النطاق الذى تم تحيده

Sub addsheet()
Dim x As Object
For Each x In Selection
Worksheets.Add().Name = x
Next x
End Sub
 

فـ كنت محتاج أدمج الكود التالى به

Sub Copier()
Dim s As String
Dim numtimes As Integer
Dim numCopies As Integer
numCopies = InputBox("How many copies do you need?")
s = InputBox("Enter the name of the Worksheet you want to copy")
For numtimes = 1 To numCopies
ActiveWorkbook.Sheets(s).Copy After:=ActiveWorkbook.Sheets(Worksheets.Count)
Next
End Sub

الكود ده بيجى رسالة تكتب رقم لـ عدد النسخ المراد نسخها
وبعدها بوكس تانى لإسم الشيت المراد نسخه

فـ بالتالى محتاج أدمج الكود ده عشان أحدد أسماء الشيتات الـ هتتنسخ من خلال النطاق الذى يتم تحديده

فـ النتيجة إن شاء الله
هتكون بالضغط على الزر
أولاً.. بوكس بتحديد عدد النسخ
ثانياً.. بوكس بيطلب مننا نكتب اسم الشيت المراد نسخه
ثالثاً.. بوكس بتحديد النطاق الـ هيكون فيه أسماء الشيتات الجديدة الـ هيتعملها Create وفى ننفس الوقت النقطة ( أولاً ) سيتم إلغاؤها لأن النقطة ( ثالثاً ) ستغنى عنها لوجود نطاق يحدد عدد النسخ
وشكراً جزيلاً مقدماً لتفهمكم وتعاونكم

[محمد هشام.]

أخي وضح طلبك أكثر. هل اسم الشيت الذي سيتم إدخاله هو اسم الشيت المراد نسخه او هو الاسم المفروض تسمية الأوراق الجديدة به. 

هل تريد انشاء أوراق جديدة باسم الخلايا التي تم تحديدها او انشاء نسخة من ورقة معينة !!!!!

 

 

[Mahmoud Atef]

@محمد هشام.

بالفعل أ/ محمد

اسم الشيت الذى سيتم إدخاله فى البوكس الذى سيظهر عن إعطاء أمر الماكرو .. هو نفسه المراد نسخه ولكن عند نسخه أريد أن تكون أسماء النسخ هى نطاق يتم تحديده به الأسماء جاهزة

وشكراً على إهتمام حضرتك

[محمد هشام.]

تفضل اخي اليك طلبك يمكنك تطويعه على حسب احتياجاتك 

Sub Créer_des_feuilles()
Dim rng As Range, dico As Range, Cell As Range
Dim arr(1 To 2) As String, f As Worksheet
    arr(1) = "المرجوا التحقق من إسم ورقة العمل"
    arr(2) = "تم نسخ اوراق العمل بنجاح"
 
On Error GoTo Errorhandling
NameWS = InputBox("أدخل إسم ورقة العمل المراد نسخها ", " نسخ ورقة العمل")
    If Evaluate("ISREF('" & NameWS & "'!A1)") Then
    Set rng = Application.InputBox(Prompt:=" حدد نطاق أسماء أوراق العمل: ", _
    Title:="تسمية أوراق العمل", _
    Default:=Selection.Address, Type:=8)
For Each dico In rng
If dico <> Empty Then
    Application.ScreenUpdating = False
    If Not Evaluate("ISREF('" & dico & "'!A1)") Then
    Sheets(NameWS).Copy After:=ActiveWorkbook.Sheets(Worksheets.Count)
    Set f = ActiveSheet: f.Name = dico:   f.DrawingObjects.Delete: f.UsedRange = f.UsedRange.Value
For Each Cell In dico
ws = ws & vbCrLf & Cell.Value
     Next Cell
    End If
 End If
Next dico
Application.ScreenUpdating = True
MsgBox arr(2) & vbCrLf & ws, vbOKOnly, "تعليمات:"

Else
MsgBox arr(1), vbCritical, "إنتباه:"

End If
Errorhandling:
End Sub

 

Create-Sheets.xlsb

تم تعديل نوفمبر 15, 2023 بواسطه محمد هشام.

[Mahmoud Atef]

@محمد هشام.

جزيت خيراً

ربنا يجعله فى ميزان حسناتك

[محمد هشام.]

العفو اخي يسعدنا اننا استطعنا مساعدتك

 

[Mahmoud Atef]

@محمد هشام.

أستأذنك إستفسار بسيط

عند أخذ أمر النسخ
تكون النسخ الجديدة كلها ( Values & Sources Formatting ) ، هل يمكن أن تكون النسخ التى تتم تكون كما هى بالمعادلات و الـ Format

بعتذر لك على الإزعاج

[محمد هشام.]

نعم اخي يمكنك دالك بتعطيل هدا الصف فقط

f.UsedRange = f.UsedRange.Value

رغم انني عند كتابة الكود لاحظت ان الفكرة  ربما لم كانت على يوزرفورم سوف تكون مميزة (لانني دائما عند الاشتغال على اي ملف اطمح الى تقديم الافضل رغم عدم طلبه ) لهدا قررت بعدما طلبت مني التعديل بانشاءه ربما يساعدك على الاشتغال على الملف بشكل افضل  مع البقاء على الكود الاول ليبقى لك اختيار ما يناسبك طبعا

 

اليك شرح الكود الاول ربما تحتاج يوما الا تعديل شيء ما

Sub Créer_des_feuilles()
Dim rng As Range, dico As Range, Cell As Range
Dim arr(1 To 2) As String, f As Worksheet
' رسالة تنبيه عند كتابة اسم  غير موجود على المصنف
    arr(1) = "المرجوا التحقق من إسم ورقة العمل"
  
  ' رسالة بنجاح النسخ تتظمن اسماء الاوراق الجديدة
    arr(2) = "تم نسخ اوراق العمل بنجاح"
 
On Error GoTo Errorhandling
NameWS = InputBox("أدخل إسم ورقة العمل المراد نسخها ", " نسخ ورقة العمل")
    ' التحقق من اسم ورقة العمل المراد نسخها
    If Evaluate("ISREF('" & NameWS & "'!A1)") Then
    Set rng = Application.InputBox(Prompt:=" حدد نطاق أسماء أوراق العمل: ", _
    Title:="تسمية أوراق العمل", _
    Default:=Selection.Address, Type:=8)
For Each dico In rng
' تجاهل الفراغات اثناء التحديد
If dico <> Empty Then
    Application.ScreenUpdating = False
  ' التحقق من وجود اسم الشيت مسبقا على المصنف
    If Not Evaluate("ISREF('" & dico & "'!A1)") Then
    Sheets(NameWS).Copy after:=ActiveWorkbook.Sheets(Worksheets.Count)
    Set f = ActiveSheet
    'تسمية اوراق العمل
    f.Name = dico
    ' حدف الازرار
    f.DrawingObjects.Delete
    'التحويل الى قيم
   ' f.UsedRange = f.UsedRange.Value

' تخزين اسماء الشيتات الجديدة
For Each Cell In dico
ws = ws & vbCrLf & Cell.Value
     Next Cell
    End If
 End If
Next dico
Application.ScreenUpdating = True
MsgBox arr(2) & vbCrLf & ws, vbOKOnly, "تعليمات:"

Else
MsgBox arr(1), vbCritical, "إنتباه:"

End If
Errorhandling:
End Sub

تفضل اخي في انتظارك بعد تجربة الملف وسوف نكون سعداء دائما بمساعدتك 

 
 

Create-Sheets_User.xlsb

[Mahmoud Atef]

شكراً لك على مجهودك الذى لا يوصف

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