Macro to Version Folders within a Folder
EE Pros.;
Greetings! I have a great Macro that Gowflow from EE built out for me that takes a specified set of "Range Names" and copies/pastes the data into a folder that's placed on the desktop. I now have a slightly different requirement which is to "version" a folder within the main desktop folder and still copy (instead of overwrite) the Range Names.
I have attached the original sample that Gowflow and I built out so you can see what this does and how it does it.
Copy-of-Saving-each-Category.xlsm
Greetings! I have a great Macro that Gowflow from EE built out for me that takes a specified set of "Range Names" and copies/pastes the data into a folder that's placed on the desktop. I now have a slightly different requirement which is to "version" a folder within the main desktop folder and still copy (instead of overwrite) the Range Names.
I have attached the original sample that Gowflow and I built out so you can see what this does and how it does it.
Copy-of-Saving-each-Category.xlsm
Gowflow,
When I fire the macro, it moves Excel into a "Not Responding" mode. I waited about two minutes before shutting the program down. Could it be caught in a loop? Have you used it to see if it works on your machine?
B.
When I fire the macro, it moves Excel into a "Not Responding" mode. I waited about two minutes before shutting the program down. Could it be caught in a loop? Have you used it to see if it works on your machine?
B.
This one is on us!
(Get your first solution completely free - no credit card required)
UNLOCK SOLUTION
Gowflow,
PERFECT! Works like a champ. Will incorporate it into master version now. Thank you for making something complex......simple! Definitely saved me time and effort.
All the best to you,
B.
PERFECT! Works like a champ. Will incorporate it into master version now. Thank you for making something complex......simple! Definitely saved me time and effort.
All the best to you,
B.
My pleasure. If you want I can keep always the last question we have monitored so if you need anything like this time you give me a buzz and will take it from there. I do this with 'selected' users I like to follow-up their projects o if your intrested let me know I will keep you in the list to follow.
Rgds/gowflow
Rgds/gowflow
Gowflow,
I put your code (that works) into my production version ( I had to change C19 and C20 to a single reference B2). I'm having to troubleshoot the Macro since making several slight changes to adapt to the production WB; I'm getting a compile error (see attached picture). The error is taking place on this line:
Then
WBName = CreateWB(Environ("USERPROF
for this specific code reference point: CreateWB
Here is the entire code I now have put in:
Function CreateWB(NewWBPath As String, VerName As String, NewWBName As String, Nam As Name) As String
Dim WS As Worksheet
Dim WSS As Worksheet
Dim NewWb As Workbook
Dim FileSaved As Boolean
Application.DisplayAlerts = False
Application.ScreenUpdating
Set WS = ActiveSheet
Set NewWb = Workbooks.Add
FileSaved = False
Do
On Error Resume Next
NewWb.SaveAs Filename:=NewWBPath & VerName & "\" & Nam.NameLocal, FileFormat:=xlExcel8
Select Case Err
Case 1004
MkDir NewWBPath
MkDir NewWBPath & VerName
On Error GoTo 0
Case 0
FileSaved = True
End Select
Loop Until FileSaved
Nam.RefersToRange.Copy NewWb.Worksheets(1).Range(
NewWb.Worksheets(1).UsedRa
ActiveSheet.Name = NewWBName
For Each WSS In NewWb.Worksheets
If InStr(1, WSS.Name, "Sheet") <> 0 Then WSS.Delete
Next WSS
NewWb.Save
CreateWB = NewWb.FullName
NewWb.Close
Set NewWb = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating
End Function
Sub GetCategories()
Dim I As Long
Dim WS As Worksheet
Dim MaxRow As Long
Dim WBName As String
Dim WBCount As Long
Dim Nam As Name
Dim VerFolder As String
If MsgBox("Are you ready to Create Workbook " & ActiveSheet.Range("C19") & " ?", vbQuestion + vbYesNo, "Send Emails") = vbYes Then
Set WS = ActiveSheet
VerFolder = Format(Now, "yyyymmdd hhmm") & " - " & ActiveSheet.Range("C20")
For Each Nam In Application.Names
If LCase(Left(Nam.Name, 8)) = "category" And LCase(Right(Nam.Name, 6)) = "survey" Then
WBName = CreateWB(Environ("USERPROF
WBCount = WBCount + 1
End If
Next Nam
MsgBox ("A total of " & WBCount & " Workbooks has been saved under worksheet name: " & ActiveSheet.Range("C19") & " successfully on the Desktop under folder " & ActiveSheet.Range("C20"))
End If
End Sub
Any ideas?
b.
Error-in-code.png
I put your code (that works) into my production version ( I had to change C19 and C20 to a single reference B2). I'm having to troubleshoot the Macro since making several slight changes to adapt to the production WB; I'm getting a compile error (see attached picture). The error is taking place on this line:
Then
WBName = CreateWB(Environ("USERPROF
for this specific code reference point: CreateWB
Here is the entire code I now have put in:
Function CreateWB(NewWBPath As String, VerName As String, NewWBName As String, Nam As Name) As String
Dim WS As Worksheet
Dim WSS As Worksheet
Dim NewWb As Workbook
Dim FileSaved As Boolean
Application.DisplayAlerts = False
Application.ScreenUpdating
Set WS = ActiveSheet
Set NewWb = Workbooks.Add
FileSaved = False
Do
On Error Resume Next
NewWb.SaveAs Filename:=NewWBPath & VerName & "\" & Nam.NameLocal, FileFormat:=xlExcel8
Select Case Err
Case 1004
MkDir NewWBPath
MkDir NewWBPath & VerName
On Error GoTo 0
Case 0
FileSaved = True
End Select
Loop Until FileSaved
Nam.RefersToRange.Copy NewWb.Worksheets(1).Range(
NewWb.Worksheets(1).UsedRa
ActiveSheet.Name = NewWBName
For Each WSS In NewWb.Worksheets
If InStr(1, WSS.Name, "Sheet") <> 0 Then WSS.Delete
Next WSS
NewWb.Save
CreateWB = NewWb.FullName
NewWb.Close
Set NewWb = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating
End Function
Sub GetCategories()
Dim I As Long
Dim WS As Worksheet
Dim MaxRow As Long
Dim WBName As String
Dim WBCount As Long
Dim Nam As Name
Dim VerFolder As String
If MsgBox("Are you ready to Create Workbook " & ActiveSheet.Range("C19") & " ?", vbQuestion + vbYesNo, "Send Emails") = vbYes Then
Set WS = ActiveSheet
VerFolder = Format(Now, "yyyymmdd hhmm") & " - " & ActiveSheet.Range("C20")
For Each Nam In Application.Names
If LCase(Left(Nam.Name, 8)) = "category" And LCase(Right(Nam.Name, 6)) = "survey" Then
WBName = CreateWB(Environ("USERPROF
WBCount = WBCount + 1
End If
Next Nam
MsgBox ("A total of " & WBCount & " Workbooks has been saved under worksheet name: " & ActiveSheet.Range("C19") & " successfully on the Desktop under folder " & ActiveSheet.Range("C20"))
End If
End Sub
Any ideas?
b.
Error-in-code.png
Yes for sure there is an error as you combined 2 cells in one !!! what is the valjjue of B2 ?
gowflow
gowflow
The value of B2 is a Text field such as C20 or C19.
B2 = ABC Company
I can add another field if that would work (such as B3) and substitute it for C19 in the code.
B.
B2 = ABC Company
I can add another field if that would work (such as B3) and substitute it for C19 in the code.
B.
nope I tried it with B2 = John's Worksheet and it worked perfectly.
You pated my code not the code you put in your workbook. Can you paste here the CreateWB Sub as it is in your workbook ?
Anyway I attached the code that works refering to B2. Simply copy it and paste it in a module.
You pated my code not the code you put in your workbook. Can you paste here the CreateWB Sub as it is in your workbook ?
Anyway I attached the code that works refering to B2. Simply copy it and paste it in a module.
Function CreateWB(NewWBPath As String, VerName As String, NewWBName As String, Nam As Name) As String
Dim WS As Worksheet
Dim WSS As Worksheet
Dim NewWb As Workbook
Dim FileSaved As Boolean
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set WS = ActiveSheet
Set NewWb = Workbooks.Add
FileSaved = False
Do
On Error Resume Next
NewWb.SaveAs Filename:=NewWBPath & VerName & "\" & Nam.NameLocal, FileFormat:=xlExcel8
Select Case Err
Case 1004
MkDir NewWBPath
MkDir NewWBPath & VerName
On Error GoTo 0
Case 0
FileSaved = True
End Select
Loop Until FileSaved
Nam.RefersToRange.Copy NewWb.Worksheets(1).Range("A1")
NewWb.Worksheets(1).UsedRange.Columns.AutoFit
ActiveSheet.Name = NewWBName
For Each WSS In NewWb.Worksheets
If InStr(1, WSS.Name, "Sheet") <> 0 Then WSS.Delete
Next WSS
NewWb.Save
CreateWB = NewWb.FullName
NewWb.Close
Set NewWb = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
Sub GetCategories()
Dim I As Long
Dim WS As Worksheet
Dim MaxRow As Long
Dim WBName As String
Dim WBCount As Long
Dim Nam As Name
Dim VerFolder As String
If MsgBox("Are you ready to Create Workbook " & ActiveSheet.Range("B2") & " ?", vbQuestion + vbYesNo, "Send Emails") = vbYes Then
Set WS = ActiveSheet
VerFolder = Format(Now, "yyyymmdd hhmm") & " - " & ActiveSheet.Range("B2")
For Each Nam In Application.Names
If LCase(Left(Nam.Name, 8)) = "category" And LCase(Right(Nam.Name, 6)) = "survey" Then
WBName = CreateWB(Environ("USERPROFILE") & "\Desktop\" & ActiveSheet.Range("B2") & "\", VerFolder, ActiveSheet.Range("B2"), Nam)
WBCount = WBCount + 1
End If
Next Nam
MsgBox ("A total of " & WBCount & " Workbooks has been saved under worksheet name: " & ActiveSheet.Range("B2") & " successfully on the Desktop under folder " & ActiveSheet.Range("B2"))
End If
End Sub
glad u did coz u scared me for a while, I bet it was a mistyping somewhere. anyhow you did not answer my comment prior to your problem read the comment above and let me know.
gowflow
gowflow
gowflow,
Here is the actual code I am using. You will see the CreateWB line about half way down.
Question for you; How do I pass the paste parameters over to the output so that the format is the same as in the original sheet? Right now it pastes it but I have to reformat every file in order for it to look the same. Seems like that would be a minor adjustment or a single line passing the parameters of "type" of paste or copy that occurs.
All the best,
B.
'This module is for saving data to the desktop
Function CreateWB(NewWBPath As String, VerName As String, NewWBName As String, Nam As Name) As String
Dim WS As Worksheet
Dim WSS As Worksheet
Dim NewWb As Workbook
Dim FileSaved As Boolean
Application.DisplayAlerts = False
Application.ScreenUpdating
Set WS = ActiveSheet
Set NewWb = Workbooks.Add
FileSaved = False
Do
On Error Resume Next
NewWb.SaveAs Filename:=NewWBPath & VerName & "\" & Nam.NameLocal, FileFormat:=xlExcel8
Select Case Err
Case 1004
MkDir NewWBPath
MkDir NewWBPath & VerName
On Error GoTo 0
Case 0
FileSaved = True
End Select
Loop Until FileSaved
Nam.RefersToRange.Copy NewWb.Worksheets(1).Range(
NewWb.Worksheets(1).UsedRa
ActiveSheet.Name = NewWBName
For Each WSS In NewWb.Worksheets
If InStr(1, WSS.Name, "Sheet") <> 0 Then WSS.Delete
Next WSS
NewWb.Save
CreateWB = NewWb.FullName
NewWb.Close
Set NewWb = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating
End Function
Sub GetCategories()
Dim I As Long
Dim WS As Worksheet
Dim MaxRow As Long
Dim WBName As String
Dim WBCount As Long
Dim Nam As Name
Dim VerFolder As String
If MsgBox("Are you ready to Create Workbook " & ActiveSheet.Range("B2") & " ?", vbQuestion + vbYesNo, "Send Emails") = vbYes Then
Set WS = ActiveSheet
VerFolder = Format(Now, "yyyymmdd hhmm") & " - " & ActiveSheet.Range("B2")
For Each Nam In Application.Names
If LCase(Left(Nam.Name, 8)) = "category" And LCase(Right(Nam.Name, 6)) = "survey" Then
WBName = CreateWB(Environ("USERPROF
WBCount = WBCount + 1
End If
Next Nam
MsgBox ("A total of " & WBCount & " Workbooks has been saved under worksheet name: " & ActiveSheet.Range("B2") & " successfully on the Desktop under folder " & ActiveSheet.Range("B2"))
End If
End Sub
Here is the actual code I am using. You will see the CreateWB line about half way down.
Question for you; How do I pass the paste parameters over to the output so that the format is the same as in the original sheet? Right now it pastes it but I have to reformat every file in order for it to look the same. Seems like that would be a minor adjustment or a single line passing the parameters of "type" of paste or copy that occurs.
All the best,
B.
'This module is for saving data to the desktop
Function CreateWB(NewWBPath As String, VerName As String, NewWBName As String, Nam As Name) As String
Dim WS As Worksheet
Dim WSS As Worksheet
Dim NewWb As Workbook
Dim FileSaved As Boolean
Application.DisplayAlerts = False
Application.ScreenUpdating
Set WS = ActiveSheet
Set NewWb = Workbooks.Add
FileSaved = False
Do
On Error Resume Next
NewWb.SaveAs Filename:=NewWBPath & VerName & "\" & Nam.NameLocal, FileFormat:=xlExcel8
Select Case Err
Case 1004
MkDir NewWBPath
MkDir NewWBPath & VerName
On Error GoTo 0
Case 0
FileSaved = True
End Select
Loop Until FileSaved
Nam.RefersToRange.Copy NewWb.Worksheets(1).Range(
NewWb.Worksheets(1).UsedRa
ActiveSheet.Name = NewWBName
For Each WSS In NewWb.Worksheets
If InStr(1, WSS.Name, "Sheet") <> 0 Then WSS.Delete
Next WSS
NewWb.Save
CreateWB = NewWb.FullName
NewWb.Close
Set NewWb = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating
End Function
Sub GetCategories()
Dim I As Long
Dim WS As Worksheet
Dim MaxRow As Long
Dim WBName As String
Dim WBCount As Long
Dim Nam As Name
Dim VerFolder As String
If MsgBox("Are you ready to Create Workbook " & ActiveSheet.Range("B2") & " ?", vbQuestion + vbYesNo, "Send Emails") = vbYes Then
Set WS = ActiveSheet
VerFolder = Format(Now, "yyyymmdd hhmm") & " - " & ActiveSheet.Range("B2")
For Each Nam In Application.Names
If LCase(Left(Nam.Name, 8)) = "category" And LCase(Right(Nam.Name, 6)) = "survey" Then
WBName = CreateWB(Environ("USERPROF
WBCount = WBCount + 1
End If
Next Nam
MsgBox ("A total of " & WBCount & " Workbooks has been saved under worksheet name: " & ActiveSheet.Range("B2") & " successfully on the Desktop under folder " & ActiveSheet.Range("B2"))
End If
End Sub
I had the Columns Autofit. Try this version is it better ?
Paste the whole code in the Module instead of the previous one.
Let me know.
gowflow
Saving-Category-VersionControl.xlsm
Paste the whole code in the Module instead of the previous one.
Function CreateWB(NewWBPath As String, VerName As String, NewWBName As String, Nam As Name) As String
Dim WS As Worksheet
Dim WSS As Worksheet
Dim NewWb As Workbook
Dim FileSaved As Boolean
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set WS = ActiveSheet
Set NewWb = Workbooks.Add
FileSaved = False
Do
On Error Resume Next
NewWb.SaveAs Filename:=NewWBPath & VerName & "\" & Nam.NameLocal, FileFormat:=xlExcel8
Select Case Err
Case 1004
MkDir NewWBPath
MkDir NewWBPath & VerName
On Error GoTo 0
Case 0
FileSaved = True
End Select
Loop Until FileSaved
Nam.RefersToRange.Copy
NewWb.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteFormats
NewWb.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
NewWb.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll
'NewWb.Worksheets(1).UsedRange.Columns.AutoFit
ActiveSheet.Name = NewWBName
For Each WSS In NewWb.Worksheets
If InStr(1, WSS.Name, "Sheet") <> 0 Then WSS.Delete
Next WSS
NewWb.Save
CreateWB = NewWb.FullName
NewWb.Close
Set NewWb = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
Sub GetCategories()
Dim I As Long
Dim WS As Worksheet
Dim MaxRow As Long
Dim WBName As String
Dim WBCount As Long
Dim Nam As Name
Dim VerFolder As String
If MsgBox("Are you ready to Create Workbook " & ActiveSheet.Range("B2") & " ?", vbQuestion + vbYesNo, "Send Emails") = vbYes Then
Set WS = ActiveSheet
VerFolder = Format(Now, "yyyymmdd hhmm") & " - " & ActiveSheet.Range("B2")
For Each Nam In Application.Names
If LCase(Left(Nam.Name, 8)) = "category" And LCase(Right(Nam.Name, 6)) = "survey" Then
WBName = CreateWB(Environ("USERPROFILE") & "\Desktop\" & ActiveSheet.Range("B2") & "\", VerFolder, ActiveSheet.Range("B2"), Nam)
WBCount = WBCount + 1
End If
Next Nam
MsgBox ("A total of " & WBCount & " Workbooks has been saved under worksheet name: " & ActiveSheet.Range("B2") & " successfully on the Desktop under folder " & ActiveSheet.Range("B2"))
End If
End Sub
Let me know.
gowflow
Saving-Category-VersionControl.xlsm
Gowflow,
Very sorry for the delay. I came down with the flu yesterday and was out all day. I'm just getting to it this morning and will follow up in an hour or so. If you haven't had this strain of Flu, believe me, you don't want it.
B.
Very sorry for the delay. I came down with the flu yesterday and was out all day. I'm just getting to it this morning and will follow up in an hour or so. If you haven't had this strain of Flu, believe me, you don't want it.
B.
Well I had worst than Flu !!!! had herpies close to my eye and it killed like hell .... but still I could manage to get your file done !!! :) (no sarcastic, just real fact) take care and take ur time no sweat.
gowflow
gowflow
Wow....that's really bad. I guess I should count my blessings.
So although feeling like I'm on a death bed, and not to be outdone by your commitment to helping me out here, I've been testing it and here is the problem.
Your change to "format" works but I have discovered another problem (hopefully easy to resolve). The Worksheet with the range name that your macro picks up and copies/pastes refers to another Worksheet because in the WS that is copied, I have formulas embedded. In otherwords, I have statements that are within the range name that instead of being strictly "text", they are pulled from another WS (e.g. =(Master_Statement!B4), and so on. Is there a way to have the macro copy and paste without carrying over the formulas? I think again, it may be a "paste option". Otherwise, what it is doing is pasting and duplicating the other reference Worksheet.
Any ideas?
B.
So although feeling like I'm on a death bed, and not to be outdone by your commitment to helping me out here, I've been testing it and here is the problem.
Your change to "format" works but I have discovered another problem (hopefully easy to resolve). The Worksheet with the range name that your macro picks up and copies/pastes refers to another Worksheet because in the WS that is copied, I have formulas embedded. In otherwords, I have statements that are within the range name that instead of being strictly "text", they are pulled from another WS (e.g. =(Master_Statement!B4), and so on. Is there a way to have the macro copy and paste without carrying over the formulas? I think again, it may be a "paste option". Otherwise, what it is doing is pasting and duplicating the other reference Worksheet.
Any ideas?
B.
yes no problem
here it is
In the Sub CreateWB replace this line
NewWb.Worksheets(1).Range(
by this line
NewWb.Worksheets(1).Range(
Save and exit run again and let me know.
gowflow
here it is
In the Sub CreateWB replace this line
NewWb.Worksheets(1).Range(
by this line
NewWb.Worksheets(1).Range(
Save and exit run again and let me know.
gowflow
Perfect! Works very well........... Thank you again for sticking with me....... if you were in my neighborhood, I'd be taking you to dinner (as soon as I'm well again!).
All the best and will keep you informed.
B.
All the best and will keep you informed.
B.
Tks and glad it worked well for you. Take care and hv a good rest. for sure u can't take me to dinner, ... :) but instead you can let me know if you need further help on other issues.
Rgds/gowflow
Rgds/gowflow
Gain unlimited access to on-demand training courses with an Experts Exchange subscription.
Get AccessWhy Experts Exchange?
Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.
Jim Murphy
Programmer at Smart IT Solutions
When asked, what has been your best career decision?
Deciding to stick with EE.
Mohamed Asif
Technical Department Head
Being involved with EE helped me to grow personally and professionally.
Carl Webster
CTP, Sr Infrastructure Consultant
Did You Know?
We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE
Ask ANY Question
Connect with Certified Experts to gain insight and support on specific technology challenges including:
- Troubleshooting
- Research
- Professional Opinions
Join our community and discover your potential
Experts Exchange is the only place where you can interact directly with leading experts in the technology field. Become a member today and access the collective knowledge of thousands of technology experts.
*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.