Public Sub Trans_to_copy()
Dim Rng As Range
Dim Mu_a$, Pth$
Dim ii%, i%, Nx%, Np%
Dim Num%, A%, B%, x%
'****************
On_1:

'يمكنك استبدال كلمة الكشف التى تظهر كأسم للملف بأى لكمة أخرى
'يتم تسمية الملف على سبيل المثال كالتالي
'الكشف - 1
'ورقم واحد نظرا لإتباطها برقم كود الموظف حسب ملف الشرح

Mu_a = "الكشف"
'****************
Np = 0
On Error Resume Next
Num = ActiveDocument.ActiveWindow.ActivePane.Pages.Count
A = InputBox("إدخل عدد الصفحات لكل موضوع ويفضل ترك الرقم الافتراضي كما هو", , 1)
B = InputBox("إدخل عدد المواضيع ويفضل ترك الرقم الافتراضى كما هو", , 1)
x = A
For ii = 1 To Num Step A
Np = Np + 1
i = ii: Nx = ii + x
Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i
  Set Rng = Selection.Range
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=Nx
    Rng.End = Selection.Bookmarks("\Page").Range.End
 Rng.Select
    Selection.Copy
    Application.Documents.Add
    Selection.Paste
   Pth = ThisDocument.Path & "\"
  ActiveDocument.SaveAs Pth & Mu_a & " - " & Np & ".docx"
ActiveDocument.Close
Next
On Error GoTo 0
ActiveDocument.Range(1, 1).Select
'يمكنك تغيير نص الرسالة التى تظهر حتى تتطابق مع الموضوع الخاص بك
MsgBox "تم تقسيم ملف كشوف المرتبات كل كشف بملف وورد مستقل بنجاح", vbInformation, ""
Set Rng = Nothing
End Sub