تعديل كود للترحيل و انشاء شيتات

[Abo Sufiyan]

السادة خبراء الاكسيل 

بعد التحية 

بعد بحث فى الموقع استطعت ان اصل الى ملف لانشاء شيت جديد باسم الذى يوضع فى الفورم الموجود ولكن انا احتاج ان يضع كمية اسماء كبيرة اكثر من 200 اسم وعمل شيتات باسمائهم فهل يمكن ان يتم تغير الجزء الخاص بالفورم بوضع الاسماء فى صف ويقوم باخذهم اسم اسم اتوماتيك دون ادخال كل اسم لوحدة

 

Personal1.xlsm

[أبومروان]

السلام عليكم ورحمه الله وبركاته

دا كود انشاء صفحات اكسل بناء علي الاسماء الموجوده  من الخلايا a1:a200

Sub CreateSheets()
    Dim sheetName As String
    Dim currentCell As Range

    For Each currentCell In Range("A1:A200")
        sheetName = currentCell.Value
        Sheets.Add.Name = sheetName
    Next
End Sub

 

تم تعديل فبراير 19, 2023 بواسطه كريم نظيم

[Abo Sufiyan]

وعلبكم السلام ورحمة الله وبركاتة

اشكرك اخى على الكود ولكن انا اريد التعديل على الكود الموجود حتى يقوم بعمل الشيت طبقا لشيت الموجود بالملف حيث يوجد ملف sample يصنع مثلة كل ما يتم طلب انشاء شيت جديد

[lionheart]

Try this code (adjust well the template worksheet)

Sub Test()
    Dim wsTemplate As Worksheet, nameList As Range, newName As String, i As Long
    Application.ScreenUpdating = False
        Set wsTemplate = ThisWorkbook.Worksheets("Vehicle")
        Set nameList = Sheets("Data").Range("A2:A11")
        For i = 1 To nameList.Rows.Count
            newName = "T_" & nameList.Cells(i, 1).Value
            If Evaluate("ISREF('" & newName & "'!A1)") Then
                Application.DisplayAlerts = False
                    ThisWorkbook.Worksheets(newName).Delete
                Application.DisplayAlerts = True
            End If
            wsTemplate.Copy After:=Worksheets(ThisWorkbook.Worksheets.Count)
            With ActiveSheet
                .Name = newName
                .Range("B2").Value = Mid(newName, 3, Len(newName))
            End With
        Next i
    Application.ScreenUpdating = True
    MsgBox "Done", 64
End Sub

 

تم تعديل فبراير 19, 2023 بواسطه lionheart

[أبومروان]

13 دقائق مضت, lionheart said:

Try this code (adjust well the template worksheet)

Sub Test()
    Dim wsTemplate As Worksheet, nameList As Range, newName As String, i As Long
    Application.ScreenUpdating = False
        Set wsTemplate = ThisWorkbook.Worksheets("Vehicle")
        Set nameList = Sheets("Data").Range("A2:A11")
        For i = 1 To nameList.Rows.Count
            newName = "T_" & nameList.Cells(i, 1).Value
            If Evaluate("ISREF('" & newName & "'!A1)") Then
                Application.DisplayAlerts = False
                    ThisWorkbook.Worksheets(newName).Delete
                Application.DisplayAlerts = True
            End If
            wsTemplate.Copy After:=Worksheets(ThisWorkbook.Worksheets.Count)
            With ActiveSheet
                .Name = newName
                .Range("B2").Value = Mid(newName, 3, Len(newName))
            End With
        Next i
    Application.ScreenUpdating = True
    MsgBox "Done", 64
End Sub

الله ينور ي استاذ @lionheart كود أكثر من رائع 🌹

[محمد يوسف ابو يوسف]

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

 

اذا كان فهمي صحيح 

هذا طلبك 

المرفق Personal1 (1).xlsm

 y = [I1].Value ''I1'هنا مسؤل عن اخذ الاسم من خلية

 

[محمد هشام.]

14 ساعات مضت, Abo Sufiyan said:

احتاج ان يضع كمية اسماء كبيرة اكثر من 200 اسم وعمل شيتات باسمائهم

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

ملاحظة :بعد ادن الاخوة الكرام بعد معاينة الكود الموجود في اليوزرفورم  السائل ربما يقصد انشاء اوراق عمل جديدة  طبق الاصل للورقة المخفية (sample) بشرط الاسماء الموجودة في عمود H شيت

( Vehicle ) واعادة تسميتها بنفس القيمة 

تم تعديل فبراير 20, 2023 بواسطه Mohamed Hicham

[محمد هشام.]

تفضل اخي ربما هدا ما تقصد  

Sub Test()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
On Error GoTo Errorhandling
Set ST = Sheet1
Set st2 = Sheet2
lr = ST.Range("H" & Rows.Count).End(xlUp).Row
Sheet1.Range("B2:B" & lr).ClearContents
st2.Visible = True
Set rng = Range("H2:H" & lr)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each ws In Worksheets
    If ws.Name <> ("Vehicle") And ws.Name <> ("Data") And ws.Name <> ("Sample") Then
        ws.Delete
    End If
Next
For Each cell In rng
    If cell <> "" Then
     Worksheets("Sample").Copy After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = cell
        Range("i19").Value = ActiveSheet.Name
       
    End If
Next cell
Errorhandling:
Sheet1.Activate
Sheet1.Range("b2").Select
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> ("Vehicle") And ws.Name <> ("Data") And ws.Name <> ("Sample") Then
ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:="", SubAddress:="" & ws.Name & "!A1" & "", ScreenTip:="", TextToDisplay:=ws.Name
ActiveCell.Offset(1, 0).Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
Next ws
st2.Visible = False
End Sub

 

 

تم تعديل فبراير 20, 2023 بواسطه Mohamed Hicham

[Abo Sufiyan]

اخى العزيز Mohamed Hicham

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

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

انتم فعلا نعم العون

 

[محمد هشام.]

العفو اخي الكريم بما انني استطعت استعاب المطلوب اليك الكود النهائي للملف ربما اسرع عند انشاء عدد كبير من اوراق العمل 

Public Sub MH_2()
Dim ws As Worksheet, WS1 As Worksheet
Dim arr As Variant, MH1 As Variant
Dim lngArr As Long, lr As Long
Dim MH2 As String
Dim rngCell As Range
temps = Timer

'باستثناء الاوراق التالية
MH2 = "Vehicle,Data,Sample"
Set WS1 = Sheet1
lr = WS1.Range("H" & WS1.Rows.Count).End(xlUp).Row
arr = WS1.Range("H2:H" & lr).Value

Application.ScreenUpdating = False
' اظهار النمودج
Sheet2.Visible = True
'حدف اوراق العمل
For Each ws In Worksheets
  If InStr(1, MH2, ws.Name) = 0 Then
    MH1 = Application.Match(ws.Name, arr, 0)
    If IsError(MH1) Then
      Application.DisplayAlerts = False
      ws.Delete
      Application.DisplayAlerts = True
    End If
  End If
Next ws

' نسخ
For lngArr = LBound(arr) To UBound(arr)
  If Len(Trim(arr(lngArr, 1))) > 0 Then
    If Not Evaluate("ISREF('" & arr(lngArr, 1) & "'!A1)") Then
      Worksheets("Sample").Copy After:=Worksheets(Worksheets.Count)
      ActiveSheet.Name = arr(lngArr, 1)    ' تسمية اوراق العمل
      Range("i19").Value = arr(lngArr, 1)   '("i19") اضافة اسم ورقة العمل للخلية '
    End If
  End If
Next lngArr

' حدف الارتباطات السابقة
With Sheet1
  .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)).ClearContents
  Set rngCell = .Range("B2")
End With

'إنشاء ارتباطات تشعبية على بيانات الاوراق الجديدة
For Each ws In ActiveWorkbook.Worksheets
  If InStr(1, MH2, ws.Name) = 0 Then
    rngCell.Hyperlinks.Add Anchor:=rngCell, Address:="", SubAddress:="" & ws.Name & "!A1" & "", ScreenTip:="", TextToDisplay:=ws.Name
    Set rngCell = rngCell.Offset(1)
  End If
Next ws

Set rngCell = Nothing
Set WS1 = Nothing
' اخفاء النمودج
Sheet2.Visible = False
Sheet1.Activate
Application.ScreenUpdating = True

MsgBox "تم انشاء" & " " & Application.Sheets.Count - 3 & " " & "ورقة عمل جديدة " & "-" & "تم تنفيد الكود في: " & Format(Timer - temps, "0.0000") & "ثانية", Exclamation, "Officena"

End Sub

 

 

Personal_V2.xlsm

تم تعديل فبراير 19, 2023 بواسطه Mohamed Hicham