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
ASKER
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.
yes I tried it let me see whats the problem.
gowflow
gowflow
yes yr correct if the folder does not exist it freezes give me 5 min
gowflow
gowflow
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
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
ASKER
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
ASKER
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 SubASKER
Got it! It works. Kudos. You do amazing work.
B.
B.
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
ASKER
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 SubLet me know.
gowflow
Saving-Category-VersionControl.xlsm
Any news ? did the last version do it for you ?
gowflow
gowflow
ASKER
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
ASKER
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
ASKER
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
Any news ?
gowflow
gowflow
ASKER
Greetings gowflow. News? The code you sent me works great; I've incorporated it into my master WB and I appreciate the help. Beyond that, I'm about 80% recovered from the flu....it's really bad around the US right now.
If you want to keep in touch maybe we should exchange email addresses?
B.
If you want to keep in touch maybe we should exchange email addresses?
B.
No problem but rules here on EE is not to exchange email addresses as it is unethical. I will keep this question monitored if and when in the future you need help pls post a link here and I will be glad to assist you. Tks for your greetings and glad you are better now. Take care.
gowflow
gowflow
gowflow
Saving-Category-VersionControl.xlsm