طلب تعديل في كود نسخ شيت في امسى الحاجة

[amine14]

السلام عليكم 

انا في امسى الحاجة لي التعديل على هذا الكود 

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 3 Then
lr = Sheets("Accounts").Range("c" & Rows.Count).End(xlUp).Rows.Value
Sheets("Sample").Select
Sheets("Sample").Copy after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = lr
End If
End Sub

"c" هذا الكود يقوم بفتح صفحة جديدة في حالة ملء أي خلية في العمود الثالث 
إلي الشيت الجديد  Sample ثم يقوم بنسخ محتوي الشيت 
ممكن حل لي مشكل 
هو انا لم احذف اسم شيت او اعدل الاسم يطلع لي خطا 
كذلك يعمل الكود عند تكرار الخلايا ... فيقوم بنسخ صفحة أخري 
المطلوب :
1-اريد كود لم احذف اسم الشيت من الخلية يتحذف ما يطلع الخطئ يبقى على حاله
2-ولم اعدل على الاسم يتعدل اسم الشيت كذلك
3-2- عدم تكرير الاسم الشيت تطلع رسالة خطا يوجد الاسم مشبه
ملاحظة:
انا وجدت هذا الكود وهو يقوم بالتعديل على اسم الشيت من خلية معينة ممكن يساعدكم الله يجزيكم خير

 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set Target = Range("A1")
If Target = "" Then Exit Sub
Application.ActiveSheet.Name = VBA.Left(Target, 31)
Exit SubEnd Sub

https://www.officena.net/ib/applications/core/interface/file/attachment.php?id=125841

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

جرب هذا الكود

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Lr As Long, My_name As String, x As Integer
On Error Resume Next
 Lr = Sheets("Accounts").Range("c" & Rows.Count).End(xlUp).Row
 My_name = Sheets("Accounts").Cells(Lr, 3)
 x = Len(Sheets(My_name).Name)
If x = 0 Then
Sheets("Sample").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = My_name
End If
On Error GoTo 0

End Sub

الملف(نموذج )مرفق

Create_sheet.rar

[amine14]

21 ساعات مضت, سليم حاصبيا said:

جرب هذا الكود

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Lr As Long, My_name As String, x As Integer
On Error Resume Next
 Lr = Sheets("Accounts").Range("c" & Rows.Count).End(xlUp).Row
 My_name = Sheets("Accounts").Cells(Lr, 3)
 x = Len(Sheets(My_name).Name)
If x = 0 Then
Sheets("Sample").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = My_name
End If
On Error GoTo 0

End Sub

الملف(نموذج )مرفق

Create_sheet.rar

شكرا لك عل الجهود ولكن اريد لم اعدل على الاسم يتعدل اسم الشيت

[amine14]

هل من رد الله يجزيكم خير 

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

يمكنك تجربة هذين الكودين مع بعض

و عسى ان يكون المطلوب

Option Explicit
Private OldVal

Private Sub Worksheet_Change(ByVal Target As Range)
Dim x%, my_name$
On Error Resume Next
If Target.Column = 3 And Target.Cells.Count = 1 Then
 my_name = Target.Value
 End If
If OldVal = my_name Or Target.Value = "" Then Exit Sub
    Application.DisplayAlerts = False
    Sheets(OldVal).Delete
    Application.DisplayAlerts = True
 x = Len(Sheets(my_name).Name)
If x = 0 Then
Sheets("Sample").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = my_name
End If
On Error GoTo 0
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim lr As Integer
If Target.Column = 3 And Target.Cells.Count = 1 Then OldVal = Target.Value
End Sub