VBA - Save each sheet as new workbook with sheet name ( choose all sheets file from a folder & save the extracted workbooks in a folder )

C

ceasar47

New Member
Joined
Apr 7, 2017
Messages
13
Office Version
  1. 2021
Platform
  1. Windows
  2. MacOS
Hi,

Can anyone please help me to create a VBA for a Workbook with multiple Worksheets which is stored in a particular folder ; extract each worksheet to a New Workbook with Sheet Name and put in a folder predefined by user as per below:

1699690786656.png


VBA Code I've tried creating is as follows:

VBA Code: 
Sub copysheet()
Application.DisplayAlerts = False

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With
    'Target File Extension (must include wildcard "*")
  myExtension = "*.xlsx*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)
 
  'Loop through each Excel file in folder
  Do While myFile <> ""
  Set wb = Workbooks.Open(Filename:=myPath & myFile)
  DoEvents
  wb.Sheets(1).Activate
 
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
  DoEvents
  wb.Sheets(1).Activate
        ws.Copy
        wb_name = ws.Name
        ActiveWorkbook.SaveAs Filename:= _
            Sheet1.Range("Savelocation").Value & wb_name & ".xlsx", FileFormat:=51
        ActiveWorkbook.Close
    Next ws
    Application.DisplayAlerts = True
'Message Box when tasks are completed
  MsgBox "Task Complete!"
  End Sub
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Sort by date Sort by votes
ceasar47 said:
Hi,

Can anyone please help me to create a VBA for a Workbook with multiple Worksheets which is stored in a particular folder ; extract each worksheet to a New Workbook with Sheet Name and put in a folder predefined by user as per below:

View attachment 101784

VBA Code I've tried creating is as follows:

VBA Code: 
Sub copysheet()
Application.DisplayAlerts = False

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With
    'Target File Extension (must include wildcard "*")
  myExtension = "*.xlsx*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)
 
  'Loop through each Excel file in folder
  Do While myFile <> ""
  Set wb = Workbooks.Open(Filename:=myPath & myFile)
  DoEvents
  wb.Sheets(1).Activate
 
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
  DoEvents
  wb.Sheets(1).Activate
        ws.Copy
        wb_name = ws.Name
        ActiveWorkbook.SaveAs Filename:= _
            Sheet1.Range("Savelocation").Value & wb_name & ".xlsx", FileFormat:=51
        ActiveWorkbook.Close
    Next ws
    Application.DisplayAlerts = True
'Message Box when tasks are completed
  MsgBox "Task Complete!"
  End Sub
Click to expand...
Try this on a test file and folder.

VBA Code: 
Public Sub copysheet()
Dim Ws As Worksheet
Dim Wb As Workbook
Dim FldrPicker As FileDialog
Dim myPath As String
Dim myExtension As String

  Application.DisplayAlerts = False
  
  Application.ScreenUpdating = False

  ' Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

  With FldrPicker
    .Title = "Select A Target Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then
      Exit Sub
    End If
    myPath = .SelectedItems(1) & "\"
  End With
     
  ' Loop through each sheet.
 
  For Each Ws In ThisWorkbook.Worksheets
      
    Ws.Copy
          
    On Error Resume Next
    Kill (myPath & Ws.Name)
    On Error GoTo 0
    
    With ActiveWorkbook
      .SaveAs Filename:=myPath & Ws.Name, FileFormat:=51
      .Close
    End With
    
  Next Ws
    
  Application.DisplayAlerts = True
  
  Application.ScreenUpdating = True
  
  MsgBox "Task Complete!"
  
End Sub
 
Upvote 0
HighAndWilder said:
Try this on a test file and folder.

VBA Code: 
Public Sub copysheet()
Dim Ws As Worksheet
Dim Wb As Workbook
Dim FldrPicker As FileDialog
Dim myPath As String
Dim myExtension As String

  Application.DisplayAlerts = False
 
  Application.ScreenUpdating = False

  ' Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

  With FldrPicker
    .Title = "Select A Target Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then
      Exit Sub
    End If
    myPath = .SelectedItems(1) & "\"
  End With
    
  ' Loop through each sheet.
 
  For Each Ws In ThisWorkbook.Worksheets
     
    Ws.Copy
         
    On Error Resume Next
    Kill (myPath & Ws.Name)
    On Error GoTo 0
   
    With ActiveWorkbook
      .SaveAs Filename:=myPath & Ws.Name, FileFormat:=51
      .Close
    End With
   
  Next Ws
   
  Application.DisplayAlerts = True
 
  Application.ScreenUpdating = True
 
  MsgBox "Task Complete!"
 
End Sub
Click to expand...

Hi ,

Thanks for your quick revert.

I've tried with the code and it is showing a blank workbook after it completes.
 
Upvote 0
ceasar47 said:
Hi,

Screen Recorded a video and shared it in the below link for easy communication. Pls check once ..

macro - Google Drive

drive.google.com drive.google.com
Click to expand...
Do you want to select another workbook which contains sheets, each one of which needs to be copied to a new workbook and the workbook taking it's name from the
sheet name?

Do you want the user to be able to select the folder into which the new workbooks are saved?
 
Upvote 0
HighAndWilder said:
Do you want to select another workbook which contains sheets, each one of which needs to be copied to a new workbook and the workbook taking it's name from the
sheet name?

Do you want the user to be able to select the folder into which the new workbooks are saved?
Click to expand...
Yes - For both the questions 🙂
 
Upvote 0
ceasar47 said:
Yes - For both the questions 🙂
Click to expand...
Delete the previous code and use this.

Run the subMain procedure.

VBA Code: 
Public Sub SubMain()
Dim strFiles As String
Dim strFolder As String

  ActiveWorkbook.Save
    
  strFiles = fncSelectFile(ActiveWorkbook.Path & "\", False, False)
  
  If strFiles = "" Then
    Exit Sub
  End If
  
  strFolder = fncSelectFolder(ActiveWorkbook.Path, "Select Destination Folder.")
  
  If strFolder = "" Then
    Exit Sub
  End If
  
  Call subCopySheetsToANewWorkbook(strFiles, strFolder)

  ActiveWorkbook.Save

End Sub

Public Sub subCopySheetsToANewWorkbook(strWorkbook As String, strFolder As String)
Dim Ws As Worksheet
Dim WbSource As Workbook
  
  Application.ScreenUpdating = False
  
  Application.DisplayAlerts = False
  
  If Not fncIsWorkbookOpen(fncGetFileNameFromFullpath(strWorkbook)) Then
    Set WbSource = Application.Workbooks.Open(strWorkbook)
  Else
    Set WbSource = Workbooks(fncGetFileNameFromFullpath(strWorkbook))
  End If
   
  For Each Ws In WbSource.Worksheets
      
    Ws.Copy
          
    On Error Resume Next
    Kill (strFolder & Ws.Name)
    On Error GoTo 0
    
    With ActiveWorkbook
      .SaveAs Filename:=strFolder & Ws.Name, FileFormat:=51
      .Close
    End With
    
  Next Ws
  
  MsgBox WbSource.Worksheets.Count & " workbooks created from the worksheets in " & _
    fncGetFileNameFromFullpath(WbSource.Name), vbOKOnly, "Confirmation"
  
  WbSource.Close savechanges:=False
  
  Application.DisplayAlerts = True
    
  Application.ScreenUpdating = True
  
End Sub

Public Function fncSelectFile(strInitialFolderName As String, _
  blnRestrictToThisFolder As Boolean, _
  blnMultipleSelection As Boolean)
  
Dim fd As Office.FileDialog
Dim strFiles As String
Dim strSelectedFiles As String
Dim vrtSelectedItem As Variant

  If Right(strInitialFolderName, 1) <> "\" Then
    strInitialFolderName = strInitialFolderName & "\"
  End If

  Set fd = Application.FileDialog(msoFileDialogFilePicker)
  
  With fd
  
      .Filters.Clear
      .Filters.Add "Excel Files", "*.xlsx?", 1
      .Filters.Add "Excel Files", "*.xlsm?", 1
      .Title = "Select an Excel file."
      .AllowMultiSelect = blnMultipleSelection
  
      .InitialFileName = strInitialFolderName
  
      If .Show = True Then
      
        For Each vrtSelectedItem In .SelectedItems
          
          ' Only add the file to the list if resides in the initial folder.
          If blnRestrictToThisFolder Then
            If strInitialFolderName = fncGetFolderNameFromFullpath(vrtSelectedItem) Then
              strSelectedFiles = strSelectedFiles & "," & vrtSelectedItem
            End If
          Else
            ' Or add the file to the list whatever folder it comes from.
            strSelectedFiles = strSelectedFiles & "," & vrtSelectedItem
          End If
          
        Next vrtSelectedItem
  
      End If
  
  End With
  
  fncSelectFile = Mid(strSelectedFiles, 2)

End Function

Public Function fncGetFileNameFromFullpath(ByVal strFullPath As String) As String
Dim varSplitList As Variant
  varSplitList = VBA.Split(strFullPath, "\")
  fncGetFileNameFromFullpath = varSplitList(UBound(varSplitList, 1))
End Function

Public Function fncGetFolderNameFromFullpath(ByVal strFullPath As String) As String
Dim varSplitList As Variant
  varSplitList = VBA.Split(strFullPath, "\")
  fncGetFolderNameFromFullpath = Replace(strFullPath, varSplitList(UBound(varSplitList, 1)), "", 1)
End Function

Public Function fncIsWorkbookOpen(strWorkbook As String)
Dim Wb As Workbook
Dim strFile As String
Dim strFolder As String

  For Each Wb In Application.Workbooks
    If strWorkbook = fncGetFileNameFromFullpath(Wb.Name) Then
      fncIsWorkbookOpen = True
      Exit For
    End If
  Next Wb
  
End Function

Public Function fncSelectFolder(strInitialFolderName As String, strTitle As String) As String
Dim FldrPicker As FileDialog
Dim strFolder As String
  
  fncSelectFolder = ""

  ' Retrieve Selected Folder Path From User.
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

  With FldrPicker
    .Title = strTitle
    .InitialFileName = strInitialFolderName
    If .Show <> -1 Then
      Exit Function
    End If
    fncSelectFolder = .SelectedItems(1) & "\"
  End With
  
  Application.DisplayAlerts = True
  
  Application.ScreenUpdating = True
  
End Function
 
Upvote 0
Solution
HighAndWilder said:
Delete the previous code and use this.

Run the subMain procedure.

VBA Code: 
Public Sub SubMain()
Dim strFiles As String
Dim strFolder As String

  ActiveWorkbook.Save
   
  strFiles = fncSelectFile(ActiveWorkbook.Path & "\", False, False)
 
  If strFiles = "" Then
    Exit Sub
  End If
 
  strFolder = fncSelectFolder(ActiveWorkbook.Path, "Select Destination Folder.")
 
  If strFolder = "" Then
    Exit Sub
  End If
 
  Call subCopySheetsToANewWorkbook(strFiles, strFolder)

  ActiveWorkbook.Save

End Sub

Public Sub subCopySheetsToANewWorkbook(strWorkbook As String, strFolder As String)
Dim Ws As Worksheet
Dim WbSource As Workbook
 
  Application.ScreenUpdating = False
 
  Application.DisplayAlerts = False
 
  If Not fncIsWorkbookOpen(fncGetFileNameFromFullpath(strWorkbook)) Then
    Set WbSource = Application.Workbooks.Open(strWorkbook)
  Else
    Set WbSource = Workbooks(fncGetFileNameFromFullpath(strWorkbook))
  End If
  
  For Each Ws In WbSource.Worksheets
     
    Ws.Copy
         
    On Error Resume Next
    Kill (strFolder & Ws.Name)
    On Error GoTo 0
   
    With ActiveWorkbook
      .SaveAs Filename:=strFolder & Ws.Name, FileFormat:=51
      .Close
    End With
   
  Next Ws
 
  MsgBox WbSource.Worksheets.Count & " workbooks created from the worksheets in " & _
    fncGetFileNameFromFullpath(WbSource.Name), vbOKOnly, "Confirmation"
 
  WbSource.Close savechanges:=False
 
  Application.DisplayAlerts = True
   
  Application.ScreenUpdating = True
 
End Sub

Public Function fncSelectFile(strInitialFolderName As String, _
  blnRestrictToThisFolder As Boolean, _
  blnMultipleSelection As Boolean)
 
Dim fd As Office.FileDialog
Dim strFiles As String
Dim strSelectedFiles As String
Dim vrtSelectedItem As Variant

  If Right(strInitialFolderName, 1) <> "\" Then
    strInitialFolderName = strInitialFolderName & "\"
  End If

  Set fd = Application.FileDialog(msoFileDialogFilePicker)
 
  With fd
 
      .Filters.Clear
      .Filters.Add "Excel Files", "*.xlsx?", 1
      .Filters.Add "Excel Files", "*.xlsm?", 1
      .Title = "Select an Excel file."
      .AllowMultiSelect = blnMultipleSelection
 
      .InitialFileName = strInitialFolderName
 
      If .Show = True Then
     
        For Each vrtSelectedItem In .SelectedItems
         
          ' Only add the file to the list if resides in the initial folder.
          If blnRestrictToThisFolder Then
            If strInitialFolderName = fncGetFolderNameFromFullpath(vrtSelectedItem) Then
              strSelectedFiles = strSelectedFiles & "," & vrtSelectedItem
            End If
          Else
            ' Or add the file to the list whatever folder it comes from.
            strSelectedFiles = strSelectedFiles & "," & vrtSelectedItem
          End If
         
        Next vrtSelectedItem
 
      End If
 
  End With
 
  fncSelectFile = Mid(strSelectedFiles, 2)

End Function

Public Function fncGetFileNameFromFullpath(ByVal strFullPath As String) As String
Dim varSplitList As Variant
  varSplitList = VBA.Split(strFullPath, "\")
  fncGetFileNameFromFullpath = varSplitList(UBound(varSplitList, 1))
End Function

Public Function fncGetFolderNameFromFullpath(ByVal strFullPath As String) As String
Dim varSplitList As Variant
  varSplitList = VBA.Split(strFullPath, "\")
  fncGetFolderNameFromFullpath = Replace(strFullPath, varSplitList(UBound(varSplitList, 1)), "", 1)
End Function

Public Function fncIsWorkbookOpen(strWorkbook As String)
Dim Wb As Workbook
Dim strFile As String
Dim strFolder As String

  For Each Wb In Application.Workbooks
    If strWorkbook = fncGetFileNameFromFullpath(Wb.Name) Then
      fncIsWorkbookOpen = True
      Exit For
    End If
  Next Wb
 
End Function

Public Function fncSelectFolder(strInitialFolderName As String, strTitle As String) As String
Dim FldrPicker As FileDialog
Dim strFolder As String
 
  fncSelectFolder = ""

  ' Retrieve Selected Folder Path From User.
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

  With FldrPicker
    .Title = strTitle
    .InitialFileName = strInitialFolderName
    If .Show <> -1 Then
      Exit Function
    End If
    fncSelectFolder = .SelectedItems(1) & "\"
  End With
 
  Application.DisplayAlerts = True
 
  Application.ScreenUpdating = True
 
End Function
Click to expand...
Thanks a TON !!!!

It worked :):)
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
Add a code or number at the end of the file name using VBA (Looped)
Replies
3
Views
121
HighAndWilder
H
V
  • Question Question
Copy each sheet to new workbook, paste values and save to specific folder
Replies
7
Views
695
JerrExcel
JerrExcel
R
  • Solved
VBA Queries refresh and Save data as TXT
Replies
2
Views
287
Artik
Artik
E
  • Question Question
Macro to Pull Summary from Multiple Files
Replies
2
Views
524
dreid1011
dreid1011
R
  • Solved
Incorporating my VBA code (that saves all sheets from an excel workbook to CSV) into a looping VBA program (just have myself stumped!)
Replies
3
Views
1K
Anthony47
A

Forum statistics

Threads
1,224,813
Messages
6,181,112
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top