كيف يتم نقل صف بأكمله وإنشاء ورقة عمل جديدة وتسمية الورقة بأحد البيانات المسجلة في نفس الصف

[القول المأثور]

السلام عليكم أخواني

تكرماً بحثت عن طريقة، لعلي أجد حلاً معكم، لدي بيانات في جدول، ويوجد أخر عمود من الجدول كود،   المطلوب نقل كل صف على حده في ورقة عمل جديدة، وتسمية الصف بالكود المسجل في نفس الصف.مرفق لكم ملف الأكسل للتوضيح أكثر. مع جزيل الشكر والامتنان.

move row.xlsm

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته ...تفضل اخي

Sub creation_onglets_MH()
Dim contenu As String
Dim lig As Long, MH As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
For Each ws In Worksheets
    If ws.Name <> "data" Then ws.Delete
Next ws
With Sheets("data")
    MH = .Range("E" & Rows.Count).End(xlUp).Row
    For lig = 4 To MH
        contenu = .Cells(lig, 5).Value
        If contenu = "" Then GoTo Suite
        If FeuilleExiste(ThisWorkbook, contenu) Then
            .Rows(lig).Copy Sheets(contenu).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        Else
            Sheets.Add
            ActiveSheet.Name = contenu
            .Rows(1).Copy Sheets(contenu).Range("A3")
            .Rows(lig).Copy Sheets(contenu).Range("A4")
                         With .Range("A:E")
            .HorizontalAlignment = xlCenter
            Range("a:a").ColumnWidth = 5
            Range("b:b").ColumnWidth = 28.71
            Range("c:c,d:d").ColumnWidth = 10
            Range("E:E").ColumnWidth = 13
            Dim i
    For i = 4 To 100
    If ws.Name <> "data" Then
        Rows(i).RowHeight = 33
              End If
      Next i
           End With
                     End If
Suite:
    Next lig
    Sheets("data").Activate
    NbSheet = ActiveWorkbook.Sheets.Count
    Range([A3], [IV3].End(xlToLeft)).Select
    Set MaPlage = Selection
    [A1].Select
    For NS = 1 To NbSheet
        Set Destination = ActiveWorkbook.Sheets(NS).Range("A3")
        MaPlage.Copy Destination
          Next NS
    Sheets("data").Move Before:=Sheets(1)
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End With
End Sub
Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean
 On Error Resume Next
 FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing)
End Function

move row_MH.xlsm

[القول المأثور]

استاذ محمد هشام، لك مني جزيل الشكر والامتنان،حسب ما هو مطلوب كيفت ووفيت.بارك الله فيك وزادك الله من علمه