PDA

View Full Version : [SOLVED:] Create a workbook from a worksheet and name it from a list



oam
08-16-2016, 08:22 PM
I have a master worksheet I would use to need to create new workbook from, add the path to the folder, and name the file from the Names list (column AA) and save and close the new file. I would also like to the code to compare the file folder content to the list and either add or take away files based on the names on the Names worksheet. I currently use the code below to create and/or delete worksheet from one file but I cannot find a similar code to work for workbook in file folders

Ideally what I need is a code that will compare file names in a file folder on the server to the file names in the Names worksheet where this code would reside in a module and either create a new file from the master sheet, name it according to the Names listing or delete the workbook all together.

Is this something that can be done?
Thank you for all your help in advance.


Option Explicit
Option Compare Text
Sub CheckSheets()
Dim wksInput As Worksheet
Dim wks As Worksheet
Dim cell As Range
Dim MaxRow As Long
Dim NotFound As Boolean
Dim Removed As String
Dim Added As String

'Assign Constant initial values
Const InputName = "Listing"
Const TemplateName = "Master"
Const TemplateName1 = "Table of Contents"
Const TemplateName2 = "Email"
Const TemplateName3 = "Table of Contents1"
Const TemplateName4 = "Lookup"
Const TemplateName5 = "Lookup2"
Const TemplateName6 = "Worksheet"
Const TemplateName7 = "Sheet1"
Set wksInput = Worksheets(InputName)

MaxRow = wksInput.Range("D" & Rows.Count).End(xlUp).Row

Application.DisplayAlerts = False
Application.ScreenUpdating = False

'Delete worksheets that don't match Posts or are not Input or Template
For Each wks In Worksheets
NotFound = True
'Keep Input and Template worksheets safe
If Not (wks.Name Like InputName Or wks.Name Like TemplateName Or wks.Name Like TemplateName1 Or wks.Name Like TemplateName2 Or wks.Name Like TemplateName3 Or wks.Name Like TemplateName4 Or wks.Name Like TemplateName5 Or wks.Name Like TemplateName6 Or wks.Name Like TemplateName7) Then

'Check all current Posts for matches
For Each cell In wksInput.Range("D2:D" & MaxRow)
If wks.Name Like cell Then
NotFound = False
Exit For
End If
Next cell
Else
NotFound = False
End If
'Match was not found, delete worksheet
If NotFound Then
'Build end message
If LenB(Removed) = 0 Then
Removed = "Worksheet '" & wks.Name & "'"
Else
Removed = Removed & " & '" & wks.Name & "'"
End If
'Delete worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
wks.Delete
' Application.DisplayAlerts = True
' Application.ScreenUpdating = True
End If
Next wks

'Check each Post for existing worksheet, copy from template if not found
For Each cell In wksInput.Range("D2:D" & MaxRow)
NotFound = True
For Each wks In Worksheets
If wks.Name Like cell Then
NotFound = False
Exit For
End If
Next wks
'Post wasn't found, copy template
If NotFound And LenB(Trim(cell & vbNullString)) <> 0 Then
'Build end message
If LenB(Added) = 0 Then
Added = "Worksheet '" & cell & "'"
Else
Added = Added & " & '" & cell & "'"
End If
'Add the worksheet
Worksheets(TemplateName).Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = cell
' ActiveSheet.Range("B2") = cell
End If
Next cell

'Added here so user sees worksheets when the message displays

' Application.DisplayAlerts = True
' Application.ScreenUpdating = True


'Final message touchups and display to user
If LenB(Removed) <> 0 And LenB(Added) <> 0 Then
Removed = Removed & " has been removed from the workbook." & vbNewLine & vbNewLine
Added = Added & " has been added to the workbook."
MsgBox Removed & Added, vbOKOnly, "Success!"
ElseIf LenB(Removed) <> 0 Then
Removed = Removed & " has been removed from the workbook."
MsgBox Removed, vbOKOnly, "Success!"
ElseIf LenB(Added) <> 0 Then
Added = Added & " has been added to the workbook."
MsgBox Added, vbOKOnly, "Success!"
End If

' Application.DisplayAlerts = False
' Application.ScreenUpdating = False

End Sub