Loop and save all open MS Excel Files based on cell reference

TheHack22

Board Regular
Joined
Feb 3, 2021
Messages
121
Office Version
  1. 365
Platform
  1. Windows
  2. Mobile
Hi VBA experts.
I found this VBA code online to save all open workbooks (Except Thisworkbook-with the code) in a predefined location with the fileName based on Cell A2.
The issue is that Cell A2 (in the raw data files) has leading and trailing spaces and I needed to incorporate a CLEAN function into this code.
I'm getting a 'Run-time error '1004'. see red text below.

Can someone please help me with this?

VBA Code:
Option Explicit
            Public ThisFile As String
            Public Path As String
           Sub CloseAndSaveOpenWorkbooks()
                Dim Wkb As Workbook
ThisFile = ActiveWorkbook.Sheets(1).Range("A2").Value ' Commented out as this piece of code was not working as intended **
                Path = "C:\Amplitude TOP LEVEL PAGES\Raw_Data\"
                With Application
                    .ScreenUpdating = False
                     '       Loop through the workbooks collection
                    For Each Wkb In Workbooks
                        With Wkb
                            If .Name <> ThisWorkbook.Name Then
                             '               if the book is read-only
                             '               don't save but close
                            If Not Wkb.ReadOnly Then
                          [B] [/B]    .SaveAs Filename:=(Path & ActiveWorkbook.Sheets(1).Range("A2").Value & ".xlsx"), FileFormat:=xlExcel8 '(line giving the error)
                             
                            End If
                             '               We save this workbook, but we don't close it
                             '               because we will quit Excel at the end,
                             '               Closing here leaves the app running, but no books
                                .Close
                            End If
                        End With
                    Next Wkb

                    .ScreenUpdating = True
                    ' .Quit 'Quit Excel
                End With
            End Sub

1641495608487.png
 
Last edited by a moderator:

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Are you trying to save the files as xlsx, or xls?
 
Upvote 0
Ok, try it like
VBA Code:
Public ThisFile As String
Public Path As String
Sub CloseAndSaveOpenWorkbooks()
   Dim Wkb As Workbook
   ThisFile = ActiveWorkbook.Sheets(1).Range("A2").Value ' Commented out as this piece of code was not working as intended **
   Path = "C:\Amplitude TOP LEVEL PAGES\Raw_Data\"
   With Application
   .ScreenUpdating = False
   '       Loop through the workbooks collection
   For Each Wkb In Workbooks
      With Wkb
         If .Name <> ThisWorkbook.Name Then
         '               if the book is read-only
         '               don't save but close
         If Not Wkb.ReadOnly Then
         .SaveAs Path & Application.Trim(ThisFile) & ".xlsx", 51
         
         End If
         '               We save this workbook, but we don't close it
         '               because we will quit Excel at the end,
         '               Closing here leaves the app running, but no books
         .Close
         End If
      End With
   Next Wkb

.ScreenUpdating = True
' .Quit 'Quit Excel
End With
End Sub
 
Upvote 0
Ok, try it like
VBA Code:
Public ThisFile As String
Public Path As String
Sub CloseAndSaveOpenWorkbooks()
   Dim Wkb As Workbook
   ThisFile = ActiveWorkbook.Sheets(1).Range("A2").Value ' Commented out as this piece of code was not working as intended **
   Path = "C:\Amplitude TOP LEVEL PAGES\Raw_Data\"
   With Application
   .ScreenUpdating = False
   '       Loop through the workbooks collection
   For Each Wkb In Workbooks
      With Wkb
         If .Name <> ThisWorkbook.Name Then
         '               if the book is read-only
         '               don't save but close
         If Not Wkb.ReadOnly Then
         .SaveAs Path & Application.Trim(ThisFile) & ".xlsx", 51
        
         End If
         '               We save this workbook, but we don't close it
         '               because we will quit Excel at the end,
         '               Closing here leaves the app running, but no books
         .Close
         End If
      End With
   Next Wkb

.ScreenUpdating = True
' .Quit 'Quit Excel
End With
End Sub
@Fluff

Thanks very much for this code. I tried it and have two issues.

The Trim Function doesn't work. I changed it to CLEAN
It now works partially with this small tweak, but the issue now is that this only saves the first file. The others are closed without saving them.
Line changed ".SaveAs Path & Application.Trim(ThisFile) & ".xlsx", 51".

Any suggestion on how to deal with the new issue, that is, it's only saving one workbook and skipping the rest without saving?

Imran
 
Upvote 0
Remove this line
VBA Code:
         .Close
otherwise it will close the workbook with the code as soon as it gets to it.
 
Upvote 0
That means what it says. What should happen in that situation?
 
Upvote 0
That's my fault, try it like
VBA Code:
Sub CloseAndSaveOpenWorkbooks()
   Dim Wkb As Workbook
   Path = "C:\Amplitude TOP LEVEL PAGES\Raw_Data\"
   With Application
   .ScreenUpdating = False
   '       Loop through the workbooks collection
   For Each Wkb In Workbooks
      With Wkb
         If .Name <> ThisWorkbook.Name Then
         '               if the book is read-only
         '               don't save but close
         If Not Wkb.ReadOnly Then
            ThisFile = Application.Clean(Wkb.Sheets(1).Range("A2").Value)
            .SaveAs Path & Application.Trim(ThisFile) & ".xlsx", 51
         
         End If
         '               We save this workbook, but we don't close it
         '               because we will quit Excel at the end,
         '               Closing here leaves the app running, but no books
'         .Close
         End If
      End With
   Next Wkb

.ScreenUpdating = True
' .Quit 'Quit Excel
End With
End Sub
 
Upvote 0
Solution

Forum statistics

Threads
1,213,536
Messages
6,114,213
Members
448,554
Latest member
Gleisner2

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