code to copy 3 sheets to a new workbook|VBA & Macros|Excel Forum|My Online Training Hub

Sub CopyVisibleNewWkbook()

' Procedure : CopyVisibleNewWkbook
' Author : Sherry Barnes-Fox
' Date : 04/09/2024
' Purpose : Copies Impact sheet (renames to Sheet1) and Definitions to new workbook

' Optimize Macro Speed
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

Dim newBook As Workbook
Dim rng As range
Dim savePath As Variant
Dim workbookName As String

' Get the new workbook name from the "Instructions" sheet
workbookName = ThisWorkbook.Worksheets("Instructions").range("$T$25").Value

' Create a new workbook
Set newBook = Workbooks.Add

' Copy visible cells from "Impact" sheet to the new workbook
Set rng = ThisWorkbook.Worksheets("Impact").Cells.SpecialCells(xlCellTypeVisible)
rng.Copy newBook.Worksheets("Sheet1").range("A1")

' Copy "Definitions" sheet to the new workbook after "Sheet1"
ThisWorkbook.Worksheets("Definitions").Copy After:=newBook.Worksheets("Sheet1")

' Copy "QCH Entity Additions" sheet to the new workbook after "Definitions"
ThisWorkbook.Worksheets("QCH Entity Additions").Copy After:=newBook.Worksheets("Definitions")

' Select "Sheet1" in the new workbook
newBook.Worksheets("Sheet1").Activate

' AutoFit columns for "Sheet1"
newBook.Worksheets("Sheet1").Cells.EntireColumn.AutoFit

' Convert Range to Table for "Sheet1"
Set rng = newBook.Worksheets("Sheet1").range("A1").CurrentRegion
newBook.Worksheets("Sheet1").ListObjects.Add(xlSrcRange, rng, , xlYes).Name = "tbl_data"

' Change Font to Black for "Sheet1"
With newBook.Worksheets("Sheet1").range("K:Q")
.Font.ThemeColor = xlThemeColorLight1
.Font.TintAndShade = 0
End With

' Define choices for the dropdown list in column L
Dim choicesL As String
choicesL = "In Scope: Inactivate, In Scope: Obsolesce, In Scope: Replicate, In Scope: Tailor, In Scope: Use Direct, Out of Scope, Unknown"

' Unlock all cells on the sheet
newBook.Worksheets("Sheet1").Cells.Locked = False

' Lock down column K
newBook.Worksheets("Sheet1").Columns("K").Locked = True

' Create dropdown lists in columns L and N for "Sheet1"
Call AddDropDown(newBook.Worksheets("Sheet1"), "L2:L" & newBook.Worksheets("Sheet1").Cells(Rows.Count, "L").End(xlUp).Row, choicesL)
Call AddDropDown(newBook.Worksheets("Sheet1"), "N2:N" & newBook.Worksheets("Sheet1").Cells(Rows.Count, "N").End(xlUp).Row, "Yes,No")

' Protect "Sheet1" to enforce the lockdown on column K and allow filtering
newBook.Worksheets("Sheet1").Protect UserInterfaceOnly:=True, AllowFiltering:=True

' Call other Macros
Application.Run ("Module2.MySort")

' Delete Unneeded Columns for "Sheet1"
' Check if column Q exists before attempting to delete
If newBook.Worksheets("Sheet1").Cells(1, "Q").EntireColumn.Column = 17 Then
' Unprotect "Sheet1" before deleting columns
newBook.Worksheets("Sheet1").Unprotect
' Delete Unneeded Columns for "Sheet1"
newBook.Worksheets("Sheet1").Columns("Q:Q").Delete
' Re-protect "Sheet1" after deleting columns
newBook.Worksheets("Sheet1").Protect UserInterfaceOnly:=True, AllowFiltering:=True
End If

' Rename the new workbook
newBook.SaveAs filename:=workbookName ' Temporary save to set the name

' Call the UpdateFormulasForQCH macro to update formulas
Call UpdateFormulasForQCH ' m_Formula Module

' Prompt user to select save location
savePath = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save the Workbook", InitialFileName:=workbookName)
If savePath <> False Then
newBook.SaveAs filename:=savePath
End If

ExitSub:
' Reset Macro Optimization Settings
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Sub AddDropDown(sheet As Worksheet, range As String, list As String)
With sheet.range(range).Validation
.Delete ' Clear any previous validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=list
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
End Sub
Function SheetExists(sheetName As String, wb As Workbook) As Boolean
Dim sht As Worksheet
On Error Resume Next
Set sht = wb.Sheets(sheetName)
On Error GoTo 0
SheetExists = Not sht Is Nothing
End Function