We help IT Professionals succeed at work.

Macro to Version Folders within a Folder

Bright01
Bright01 asked
on
378 Views
Last Modified: 2013-01-09
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
Comment
Watch Question

gowflowPartner
CERTIFIED EXPERT

Commented:
Is this what your looking for ?
gowflow
Saving-Category-VersionControl.xlsm

Author

Commented:
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.
gowflowPartner
CERTIFIED EXPERT

Commented:
yes I tried it let me see whats the problem.
gowflow
gowflowPartner
CERTIFIED EXPERT

Commented:
yes yr correct if the folder does not exist it freezes give me 5 min
gowflow
Partner
CERTIFIED EXPERT
Commented:
This one is on us!
(Get your first solution completely free - no credit card required)
UNLOCK SOLUTION

Author

Commented:
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.
gowflowPartner
CERTIFIED EXPERT

Commented:
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

Author

Commented:
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("USERPROFILE") & "\Desktop\" & ActiveSheet.Range("C20") & "\", VerFolder, ActiveSheet.Range("C19"), Nam)

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 = 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("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("USERPROFILE") & "\Desktop\" & ActiveSheet.Range("C20") & "\", VerFolder, ActiveSheet.Range("C19"), Nam)
            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
gowflowPartner
CERTIFIED EXPERT

Commented:
Yes for sure there is an error as you combined 2 cells in one !!! what is the valjjue of B2 ?
gowflow

Author

Commented:
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.
gowflowPartner
CERTIFIED EXPERT

Commented:
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.

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

Open in new window

gowflow

Author

Commented:
Got it!  It works.  Kudos.  You do amazing work.

B.
gowflowPartner
CERTIFIED EXPERT

Commented:
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

Author

Commented:
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 = 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
gowflowPartner
CERTIFIED EXPERT

Commented:
I had the Columns Autofit. Try this version is it  better ?

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

Open in new window



Let me know.
gowflow
Saving-Category-VersionControl.xlsm
gowflowPartner
CERTIFIED EXPERT

Commented:
Any news ? did the last version do it for you ?  
gowflow

Author

Commented:
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.
gowflowPartner
CERTIFIED EXPERT

Commented:
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

Author

Commented:
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.
gowflowPartner
CERTIFIED EXPERT

Commented:
yes no problem
here it is

In the Sub CreateWB replace this line
NewWb.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll

by this line
NewWb.Worksheets(1).Range("A1").PasteSpecial Paste:=xlValues

Save and exit run again and let me know.
gowflow

Author

Commented:
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.
gowflowPartner
CERTIFIED EXPERT

Commented:
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
gowflowPartner
CERTIFIED EXPERT

Commented:
Any news ?
gowflow

Author

Commented:
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.
gowflowPartner
CERTIFIED EXPERT

Commented:
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

Gain unlimited access to on-demand training courses with an Experts Exchange subscription.

Get Access
Why 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
Empower Your Career
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
Unlock the solution to this question.
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.

OR

Please enter a first name

Please enter a last name

8+ characters (letters, numbers, and a symbol)

By clicking, you agree to the Terms of Use and Privacy Policy.