تغيير أسماء أوراق العمل

[marwa41]

السلام عليكم .. لابد من التحية عند بدء أى مشاركة ,,تغيير أسماء أوراق العمل  مثال hakan4 ..تجعلها باسم آخر دون التأثير على كود البرمجة 

المشكلة في كود البرمجة الذي تضعه في عمود b لاضافة ورقة جديدة يجب تغيير برمجته أو وضع زر منفرد لإضافة ورقة جديدة وإعادة تسميتها بإسم خانة معينة دون الإعتماد ع   لى العموم b 

mango_MH2023.xlsm

[محمد هشام.]

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

Sub Copie_Sheets_Numérotée_MH()
  Dim Ind As Integer
  Dim FlgExist As Boolean, Test As String
  Application.ScreenUpdating = False
 Sheet3.Copy After:=Sheets(Sheets.Count)
  Ind = 2
  Do
    On Error Resume Next
    Test = Sheets("hakan" & Ind).Range("A1").Value
    If Err.Number = 0 Then FlgExist = True: Ind = Ind + 1 Else FlgExist = False
  Loop While FlgExist
  On Error GoTo 0
  ActiveSheet.Name = "hakan" & Ind
  Sheet2.Select
   Application.Calculation = xlAutomatic
  Application.ScreenUpdating = True
End Sub

mango_MH3.xlsm

[marwa41]

الله ينور وتسلم وبارك الله فيكم 

هل ممكن زيادة ان  يتم  كتابة الاسم فى مكان  الهيبرلنك ايضا   فى صفحة TOUTAL 

لكن بدون تعديل فى اكوادك السابقة 

[محمد هشام.]

ماذا تقصد بالاسم مكان الهيبرلنك؟

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

[الخطيب بيبوو]

تسلم ايدك 

لكن عند كتابة اسم صفحة  فى عمود الهايبر لينك

يقوم بفتح صفحة جديدة بنفس اسم المكتوب فى  الهايبر لينك 

مع الاحتفاظ بكل الاكواد السابقة 

 

 

 

 

[محمد هشام.]

هل تقصد أنك تريد عند الكتابة في عمود a يتم إنشاء ورقة جديدة بنفس الإسم في حالة عدم وجودها على الملف او شيئ آخر وضح  طلبك أكثر  لكي أحاول مساعدتك 

[marwa41]

نعم هذا بالفعل مع الاحتفاظ بكل ما سبق

 

[محمد هشام.]

تضل اخي الفاضل هدا كود اخر لانشاء ورقة جديدة وتسميتها باخر قيمة موجودة على عمود A

Sub Bouton1_Cliquer()
Dim lastLine As Integer
Dim NameSheet As String
Dim MH As Boolean
lastLine = ThisWorkbook.Sheets("toutal").Range("A" & Rows.Count).End(xlUp).Row
NameSheet = ThisWorkbook.Sheets("toutal").Range("A" & lastLine)
MH = feuilleExiste(NameSheet)
If MH = True Then
        MsgBox "يتعذر انشاء ورقة جديدة بسبب وجودها مسبقا او خانة الاسم فارغة", vbInformation
Else
      Worksheets("hakan").Copy After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Worksheets("toutal").Cells(Rows.Count, 1).End(xlUp).Value
    ThisWorkbook.Sheets("toutal").Activate
    End If
End Sub
Function feuilleExiste(FeuilleAVerifier As String) As Boolean
On Error Resume Next
ThisWorkbook.Sheets(FeuilleAVerifier).Name = Sheets(FeuilleAVerifier).Name
feuilleExiste = (Err.Number = 0)
End Function

mango_MH4.xlsm