[حل شده] ايجاد فايلهاي جداگانه از شيتهاي يك فايل اكسل

[gha3emi]

سلام
آيا راهي براي اينكه به ازاي تك تك شيتهاي يك فايل اكسل يك فايل با نام همان شيت در يك مسير ايجاد كرد
مثلا يك فايل اكسل داريم كه 20 تا شيت داره و ما مي خواهيم 20 تا فايل مجزا از هر شيت با نام همون داشته باشيم
ممنون از راهنمايتون

[amir_ts]

با سلام از این کد ها در قسمت کد نویسی استفاده کنید.

[LEFT][COLOR=#323232][FONT=Consolas]Sub Splitbook()[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]
[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]Dim xPath As String[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]xPath = Application.ActiveWorkbook.Path[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]Application.ScreenUpdating = False[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]Application.DisplayAlerts = False[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]For Each xWs In ThisWorkbook.Sheets[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]    xWs.Copy[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]    Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xls"[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]    Application.ActiveWorkbook.Close False[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]Next[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]Application.DisplayAlerts = True[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]Application.ScreenUpdating = True[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]End Sub[/FONT][/COLOR][/LEFT]

[amir_ts]

فایل ارسال شد.

[gha3emi]

سلام
ممنون
عالي بود
اگه بشه مسير ذخيره فايلها رو بپرسه خيلي خوب ميشه

[iranweld]

با یک inputbox قابل انجام است

Sub Splitbook()

Dim xPath As String
xPath = InputBox("select path", "output path for file", "d:\test")
If xPath = "" Then GoTo 0
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
    ws.Copy
    Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & ws.Name & ".xls"
    Application.ActiveWorkbook.Close False
Next
0
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub 

[gha3emi]

سلام
بازم ممنون
من خواستم شرط بذارم كه ا گه مسير وجود نداشت اون رو بسازه ولي موفق نشدم
اگه زحمتي نيست در اين مورد هم راهنماييم كنيد

[iranweld]

سلام
بازم ممنون
من خواستم شرط بذارم كه ا گه مسير وجود نداشت اون رو بسازه ولي موفق نشدم
اگه زحمتي نيست در اين مورد هم راهنماييم كنيد

با سلام

با استفاده از دستور ذیل مسیر فولدر چک میگردد و اگر فولدر موجود نبود ایجاد میگردد

If Len(Dir(xPath, vbDirectory)) = 0 Then
   MkDir xPath
  End If 

کد ماکرو کلی

Sub Splitbook()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim xPath As String
xPath = InputBox("select path", "output path for file", "d:\test")

If xPath = "" Then GoTo 0

If Len(Dir(xPath, vbDirectory)) = 0 Then
   MkDir xPath
  End If
   
   
For Each ws In ThisWorkbook.Sheets
    ws.Copy
    Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & ws.Name & ".xls"
   
    Application.ActiveWorkbook.Close False
    
Next
0

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub 

[amir_ts]

دوست عزیز این فایل رو هم نگاه کنید اگر آدرس فایل مورد نظر رو وارد کنید شیت های فایل مورد نظر رو جدا میکنه.(با تشکر ویژه از جناب iranweld عزیز)

[LEFT]Private Sub CommandButton1_Click()


Dim xlApp As Object
Dim wbSource As Object
Dim wbNew As Object
Dim ws As Worksheet
Dim strFileName As String


    
    strFileName = TextBox1.Text


    Set xlApp = CreateObject("Excel.Application")
   
   Set wbSource = xlApp.Workbooks.Open(strFileName)
    
    For Each ws In wbSource.Worksheets
         ws.Copy
         Set wbNew = xlApp.ActiveWorkbook
         wbNew.SaveAs wbSource.Path & xlApp.PathSeparator & ws.Name & ".xlsx"
         wbNew.Close
         Set wbNew = Nothing
    Next ws


    wbSource.Close SaveChanges:=False
    Set wbSource = Nothing


    xlApp.Quit
    Set xlApp = Nothing


End Sub

[/LEFT]

[gha3emi]

ممنونم عالي بود