تصدير مجموعة من أوراق العمل في ملف واحد

[sof17]

السلام عليكم أريد تغيير في هذا الكود بحيث يقوم بتصدير جميع الأوراق ما عدا الرئيسة في ملف واحد وليس كما هو في الكود ورقة واحدة فقط ويأخذ نفس إسم الملف

تصدير أروق عمل.xls

[محمد هشام.]

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

جرب هدا 

Sub split()
    Dim Wb As Workbook, Ws As Worksheet
    Dim F As Workbook, filePath As String, Cpt()
    filePath = Application.ActiveWorkbook.Path: Set Sh = Sheets(1) '("الرئيسية")
  
    With Application
   .ScreenUpdating = False
   .DisplayAlerts = False
    
    Set Wb = ActiveWorkbook:    Set F = Workbooks.Add
    
    For Each Ws In Wb.Worksheets
    If Ws.Name <> Sh.Name Then
        n = n + 1
        ReDim Preserve Cpt(1 To n)
                 Cpt(n) = Ws.Name
        End If
    Next Ws
Wb.Sheets(Cpt).Copy After:=F.Sheets(F.Sheets.Count)
 On Error Resume Next: F.Sheets(1).Delete: On Error GoTo 0
 Application.ActiveWorkbook.SaveAs Filename:=filePath & "\" & Wb.Name & ".xlsx"
 F.Close

  .ScreenUpdating = True
  .DisplayAlerts = True
 End With
 
End Sub

 

تصدير أروق عمل.xls

[sof17]

شكرا الأستاذ هشام وهو المطلوب  

سؤال : لماذ حذف الشيت 1  

: F.Sheets(1).Delete:

[محمد هشام.]

4 ساعات مضت, sof17 said:

سؤال : لماذ حذف الشيت 1  

ببساطة يمكنك الغاء السطر 

On Error Resume Next: F.Sheets(1).Delete: On Error GoTo 0

ومعاينة الملف بعد تنفيد الكود واختيار ما يناسبك 😉

[محمد هشام.]

 بطريقة اخرى 

17 ساعات مضت, sof17 said:

سؤال : لماذ حذف الشيت 1 

Sub split2()
Dim sh As Worksheet, Cpt
For Each sh In ThisWorkbook.Worksheets
Set F = Sheets(1)
If sh.Name <> F.Name Then Cpt = Cpt & "|" & sh.Name
Next sh
 With Application
   .ScreenUpdating = False
   .DisplayAlerts = False
Cpt = split(Mid(Cpt, 2), "|")
Sheets(Cpt).Copy
    With ActiveWorkbook
            .SaveAs ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, _
                 InStrRev(ThisWorkbook.Name, ".") - 1) & ".xlsx", FileFormat:=51
         .Close
       End With
    .ScreenUpdating = True
  .DisplayAlerts = True
 End With
End Sub

Or

Dim sh As Worksheet, Cpt
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> "الرئيسية" Then Cpt = Cpt & "|" & sh.Name
Next sh

 

تصدير أروق عمل.xls

 

تم تعديل April 3 بواسطه محمد هشام.

[sof17]

شكرا أستاذ هشام