Solved

Macro to Version Folders within a Folder

Posted on 2013-01-03
25
320 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
0
Comment
Question by:Bright01
  • 15
  • 10
25 Comments
 
LVL 29

Expert Comment

by:gowflow
ID: 38740999
Is this what your looking for ?
gowflow
Saving-Category-VersionControl.xlsm
0
 

Author Comment

by:Bright01
ID: 38741177
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.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 38741181
yes I tried it let me see whats the problem.
gowflow
0
 
LVL 29

Expert Comment

by:gowflow
ID: 38741188
yes yr correct if the folder does not exist it freezes give me 5 min
gowflow
0
 
LVL 29

Accepted Solution

by:
gowflow earned 500 total points
ID: 38741210
Deeply sorry my mistake. Pls chk this version.
gowflow
Saving-Category-VersionControl.xlsm
0
 

Author Closing Comment

by:Bright01
ID: 38741273
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.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 38741293
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
0
 

Author Comment

by:Bright01
ID: 38741747
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
0
 
LVL 29

Expert Comment

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

Author Comment

by:Bright01
ID: 38741923
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.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 38741954
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
0
 

Author Comment

by:Bright01
ID: 38742124
Got it!  It works.  Kudos.  You do amazing work.

B.
0
How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

 
LVL 29

Expert Comment

by:gowflow
ID: 38742275
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
0
 

Author Comment

by:Bright01
ID: 38743328
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
0
 
LVL 29

Expert Comment

by:gowflow
ID: 38743632
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
0
 
LVL 29

Expert Comment

by:gowflow
ID: 38745617
Any news ? did the last version do it for you ?  
gowflow
0
 

Author Comment

by:Bright01
ID: 38746713
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.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 38746718
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
0
 

Author Comment

by:Bright01
ID: 38746773
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.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 38746777
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
0
 

Author Comment

by:Bright01
ID: 38747298
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.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 38747562
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
0
 
LVL 29

Expert Comment

by:gowflow
ID: 38757249
Any news ?
gowflow
0
 

Author Comment

by:Bright01
ID: 38757289
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.
0
 
LVL 29

Expert Comment

by:gowflow
ID: 38758025
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
0

Featured Post

Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

Join & Write a Comment

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
Approximate matching with VLOOKUP and MATCH seems to me to be a greatly under-used technique, and one which is vital for getting good performance out of large lookups. Until recently I would always have advised using an exact match for simplicity an…
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

757 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now