Hello,
I want to create a macro that will save all open workbooks (not including the active workbook) to a specified folder.
basically, I will open approx 5 - 10 workbooks from email attachments, then on my master sheet, I click a command button, and it should save all the opened attachements to a folder.
can anyone assist please?
thanks,
mike.
Try this codeCopy the Excel VBA code
Option Explicit Sub SaveOpenfiles() Dim wk As Workbook Dim fpath As String Application.ScreenUpdating = False Application.DisplayAlerts = False fpath = "D:\Test\" For Each wk In Workbooks With wk If .Name <> ThisWorkbook.Name Then .SaveAs (fpath & wk.Name) .Close End If End With Next wk Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub
Select the workbook in which you want to store the Excel VBA code
Hold the Alt key, and press the F11 key, to open the Visual Basic Editor
Choose Insert | Module
Where the cursor is flashing, choose Edit | Paste
To run the Excel VBA code:
Choose Tools | Macro | Macros
Select a macro in the list, and click the Run button.
If I have helped, Don't forget to add to my reputation (click on the star below the post)
Don't forget to mark threads as "Solved" (Thread Tools->Mark thread as Solved)
Use code tags when posting your VBA code: [code] Your code here [/code]
Worked exactly as I hoped it would.
Thankyou very much for your solution.
I have 1 more question, (not sure if I should raise another thread for it)
I now have 2 buttons on my master sheet. 1 for saving the workbooks (thanks to you) and another button to list the workbooks as hyper links in my active workbook.
If I wanted to combine these 2 buttons into 1 button that does both jobs, could I do that? would there be much tweaking of the code? or could I simply amalgamate the 2 macros?
here are the 2 macros;
and;Sub SaveOpenfiles() Dim wk As Workbook Dim fpath As String Application.ScreenUpdating = False Application.DisplayAlerts = False fpath = "Z:\NEW PROSPECTS\Completed Prospect forms 2012\" For Each wk In Workbooks With wk If .Name <> ThisWorkbook.Name Then .SaveAs (fpath & wk.Name) .Close End If End With Next wk Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub
Sub listem() Dim wb As Workbook Dim uRows As Long Dim myPath As String For Each wb In Application.Workbooks If wb.Name <> ThisWorkbook.Name _ And LCase(Left(wb.Name, 8)) <> "personal" _ Then myPath = "Z:\NEW PROSPECTS\Completed Prospect forms 2012" & "\" & wb.Name uRows = Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row Cells(uRows, 1).Hyperlinks.Add Cells(uRows, 1), myPath, , , wb.Name End If Next wb End Sub
can anyone assist with combining these 2 macros into one?
Try thisSub SaveOpenfiles() Dim wk As Workbook Dim fpath As String Dim uRows As Long Application.ScreenUpdating = False Application.DisplayAlerts = False fpath = "Z:\NEW PROSPECTS\Completed Prospect forms 2012\" For Each wk In Workbooks With wk If .Name <> ThisWorkbook.Name And LCase(Left(.Name, 8)) <> "personal" Then uRows = .Sheets(1).Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row .Cells(uRows, 1).Hyperlinks.Add .Cells(uRows, 1), fPath & .Name, , , .Name .SaveAs (fpath & wk.Name) .Close End If End With Next wk Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub
Last edited by arlu1201; 05-29-2012 at 09:50 AM. Reason: Corrected error
hi Arlette,
I get a "Run-time error '438' Object doesn't support this property or method on line;
uRows = .Sheets(1).Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
Change it to thisAlso change this rowuRows = .Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Rowto.Cells(uRows, 1).Hyperlinks.Add .Cells(uRows, 1), myPath & .Name, , , .Name
I missed out on changing mypath to fpath..Cells(uRows, 1).Hyperlinks.Add .Cells(uRows, 1), fpath & .Name, , , .Name
im getting the same "Run-time error '438' Object doesn't support this property or method" on the above line now..Cells(uRows, 1).Hyperlinks.Add .Cells(uRows, 1), fpath & .Name, , , .Name
Sorry for being a pain. Your help is greatly appreciated.
Your updated code hereSub SaveOpenfiles() Dim wk As Workbook Dim fpath As String Dim uRows As Long Application.ScreenUpdating = False Application.DisplayAlerts = False fpath = "Z:\NEW PROSPECTS\Completed Prospect forms 2012\" For Each wk In Workbooks With wk If .Name <> ThisWorkbook.Name And LCase(Left(.Name, 8)) <> "personal" Then uRows = ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row ThisWorkbook.Worksheets(1).Cells(uRows, 1).Hyperlinks.Add ThisWorkbook.Worksheets(1).Cells(uRows, 1), fpath & .Name, , , .Name .SaveAs (fpath & wk.Name) .Close End If End With Next wk Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub
Absolutely perfect.
we got off on a bad start, but I am now forever in your debt.
again, Sincere thanks for this.
this has cut my workload from about 1 hour per day, to about 30 seconds per day.
thank-you.
Am glad it worked for you. We are all here to help each other, and thats what counts. All bad things can be forgiven n forgotten.
There are currently 1 users browsing this thread. (0 members and 1 guests)
Posting Permissions
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks