انشاء شيت بعد ضغط كلمة ترحيل

[ابو هاله النبلسي]

السلام عليكم في الملف المرفق شيتان اثنان الاول استمارة فيها بيانات حسب اسم المعلم يتم التقييم بعد ان يتم ملي الاستمارة ونظغط كلمة ترحيل يتم ترحيل الاسم وباقي البيانات الى استمارة ثانية خلاصه وانشاء حسب اسم المعلم شيت مستقل ببياناته 

التفاضل.xlsm

[lionheart]

Try this code

Sub Test()
    Dim wk As Worksheet, sh As Worksheet, ws As Worksheet, lr As Long
    Set wk = ThisWorkbook.Worksheets(1)
    Set sh = ThisWorkbook.Worksheets(2)
    Set ws = CopyWorksheet(wk.Name, wk.Range("B5").Value)
    Application.ScreenUpdating = False
        With sh
            lr = .Cells(Rows.Count, "J").End(xlUp).Row + 1
            .Range("B" & lr).Resize(, 5).Value = wk.Range("B5").Resize(, 5).Value
            .Range("I" & lr).Resize(, 3).Value = Array(wk.Range("D13").Value, wk.Range("D23").Value, wk.Range("D30").Value)
            .Range("L" & lr).Formula = "=SUM(I" & lr & ":K" & lr & ")"
            .Range("N" & lr).Value = wk.Range("F41").Value
            Application.Goto .Range("A1")
        End With
    Application.ScreenUpdating = True
End Sub

Function CopyWorksheet(ByVal sheetName As String, ByVal newName As String) As Worksheet
    Application.ScreenUpdating = False
        On Error Resume Next
            Application.DisplayAlerts = False
                ThisWorkbook.Worksheets(newName).Delete
            Application.DisplayAlerts = True
        On Error GoTo 0
        ThisWorkbook.Worksheets(sheetName).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        ActiveSheet.Name = newName
        Set CopyWorksheet = ActiveSheet
    Application.ScreenUpdating = True
End Function

 

[ابو هاله النبلسي]

good work thanks very mach dear