المساعدة في كود ترحيل

[hassan rady]

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

في المرفق ملف تجريبي لبيانات طلاب 

المطلوب كود ينشأ صفحة باسم كل فصل مع ترحيل البيانات

انا ابغى الكود عشان اطبقه على اي بيانات بنفس الفكرة اذا امكن

 

شكرا لكم

TEST.xlsb.xlsx

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

جرب هذا الكود

Option Explicit
  Dim sh As Worksheet
  Dim Other_sh As Worksheet
  Dim Rg As Range
  Dim All_RG As Range
  Dim lc%, i%, Ro%, Arr(), itm
'+++++++++++++++++++++++
Sub creat_shett()
Set sh = Sheets("Sheet1")
lc = sh.Cells(Rows.Count, 3).End(3).Row

For Each Rg In sh.Range("C2:C" & lc)
    If Rg.Value <> "" Then
        If Not Application.Evaluate("ISREF('" & Rg.Value & "'!A1)") Then
        sh.Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = Rg.Value
       End If
    End If
Next
add_data
End Sub
Sub add_data()
Set sh = Sheets("Sheet1")
 For Each Other_sh In Sheets
 If Other_sh.Name <> "Sheet1" Then
  ReDim Preserve Arr(i)
  Arr(i) = Other_sh.Name
  i = i + 1
 End If
 Next
 For Each itm In Arr
  Set Other_sh = Sheets(itm)
   With Other_sh
      Set All_RG = .Range("A1").CurrentRegion
       Ro = All_RG.Rows.Count
           If Ro > 1 Then
             Set All_RG = All_RG.Offset(1).Resize(Ro - 1)
             All_RG.Clear
           End If
       .Range("Z1") = sh.Cells(1, 3)
       .Range("Z2") = .Name
        sh.Range("A1").CurrentRegion.AdvancedFilter 2, _
       .Range("Z1:Z2"), .Range("A1:d1")
       .Range("Z1:Z2").Clear
   End With
  Next
   
End Sub

الملف مرفق

 

Hasan_rady.xlsm

[hassan rady]

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

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

كل ما هو سطر  Dim  يكون متغير