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
gowflow
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
gowflow