CODEWITHSUNDEEP
pythonpython-3.xexcelvba
Cecilie Pedersen
Cecilie Pedersen

Reputation: 1

Saving Excel worksheets as separate files and looping through folder

How can I separate all the Excel files in a folder into separate sheets?

All the files have two sheets called results and datapoints.

I'm using VBA in Excel.

Sub LoopThroughFilesAndSplit()
    Dim xFd As FileDialog
    Dim xFdItem As Variant
    Dim xFileName As String
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show = -1 Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
        xFileName = Dir(xFdItem & "*.xlsm*")
        NewFileName = Left(xFileName, Len(xFileName) - 5)
        Do While xFileName <> ""
            With Workbooks.Open(xFdItem & xFileName)
                Dim FPath As String
                FPath = Application.ActiveWorkbook.Path
                Application.ScreenUpdating = False
                Application.DisplayAlerts = False
                For Each ws In ThisWorkbook.Sheets
                    ws.Copy
                    Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & NewFileName & "-" & ws.Name & ".xlsx"
                    Application.ActiveWorkbook.Close False
                Next
                Application.DisplayAlerts = True
                Application.ScreenUpdating = True
            End With
            xFileName = Dir
        Loop
    End If
End Sub

It's only working on the sheet I'm putting the code into and isn't looping through the folder.

If anyone knows how to do this in Python, that's the platform I wanted to learn. I couldn't find any template for this purpose.

Upvotes: 0

Views: 52

Answers (1)

Алексей Р
Алексей Р

Reputation: 7627

Try this VBA code

Option Explicit

Sub LoopThroughFilesAndSplit()
    Dim xFd As FileDialog, xFdItem As Variant, xFileName As String, NewFileName As String, ws As Object
    
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show = -1 Then
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
        xFileName = Dir(xFdItem & "*.xlsm*")
        Do While xFileName <> ""
            NewFileName = Left(xFileName, Len(xFileName) - 5) 'move inside loop
            With Workbooks.Open(xFdItem & xFileName)
                For Each ws In .Sheets  'remove ThisWorkbook so will be used `With Workbooks.Open`
                    ws.Copy
                    ActiveWorkbook.SaveAs Filename:=.Path & "\" & NewFileName & "-" & ws.Name & ".xlsx"
                    ActiveWorkbook.Close False
                Next
                .Close False    'close opened `With Workbooks.Open`
            End With
            xFileName = Dir
        Loop
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End If
End Sub

Upvotes: 1

Related Questions