I would like to write a vba code that will not allow to add duplicate sheets with same name. I have a code that is assigned to button on the sheet that is used to change the name of the active sheet.
Sheets are copied from "Main" sheet and hence all the sheets will have button to rename the sheet based on the value selected in the cells A8 and K11 (Both these cells have drop down list with values).
My concern is when user selects the button to rename the sheet, it should look for all the sheets in workbook and display a message if duplicate sheet exists else it should rename the sheet. I am confused in passing values, I am still a starter. Please help
Sub RenameCurrentSheet()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim ws As Worksheet
ThisWorkbook.Unprotect Password:="xyz"
For x = 1 To worksh
If ActiveSheet.Name = "MainSheet" Then
MsgBox "You Cannot Change Name of This Sheet!!!"
Exit For
Else
ActiveSheet.Name = Range("A8").Value & "-" & Range("K11").Value
Exit For
End If
Next x
Application.DisplayAlerts = True
ThisWorkbook.Protect Password:="xyz"
End Sub
To iterate through the worksheets use code like this:
dim wks as Worksheet
for I = 1 to Application.Worksheets.Count
set wks = Application.Worksheets(i)
Debug.Print wks.Name
.... whatever else you want do do
next i
set wks = Nothing ' When done with the object
Just try and reference the worksheet to see if it exists - if it throws an error, then the sheet doesn't exist.
Your code fails as you're always looking at the activesheet, but never changing which sheet is active.
Public Sub CopyAndRenameSheet()
Dim wrkSht As Worksheet
Dim sNewName As String
With ThisWorkbook
'Copy the template to the end of the workbook.
.Worksheets("MainSheet").Copy After:=.Sheets(.Sheets.Count)
'Set reference to last sheet in workbook (the one you've just copied).
Set wrkSht = .Worksheets(.Sheets.Count)
With wrkSht
'Get the new name from the ranges.
sNewName = .Range("A8") & "-" & .Range("K11")
If WorkSheetExists(sNewName) Then
MsgBox "You Cannot Change Name of This Sheet!!!", vbOKOnly + vbCritical
'Do something with the sheet, otherwise you'll be left with a
'sheet called something like "MainSheet (1)".
Application.DisplayAlerts = False
wrkSht.Delete
Application.DisplayAlerts = True
Else
.Unprotect Password:="xyz"
wrkSht.Name = sNewName
.Protect Password:="xyz"
End If
End With
End With
End Sub
Public Function WorkSheetExists(SheetName As String, Optional WrkBk As Workbook) As Boolean
Dim wrkSht As Worksheet
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
On Error Resume Next
Set wrkSht = WrkBk.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
This code copies the name to be assigned from the template instead of the ActiveSheet. If you create the name from the active sheet and make sure that the name meets Excel requirements for sheet names, this code ought to work.
Related
I'm adding a new worksheet to my workbook with
Application.ScreenUpdating = False
SheetExists = False
For Each WS In Worksheets
If WS.Name = "BLANK" Then
SheetExists = True
End If
Next WS
If Not SheetExists Then
Sheets.Add
ActiveSheet.Name = "BLANK"
End If
Is there any way to sheets.add silently without bringing focus to or activating the new added sheet? I just want to stay on the sheet (ie. Sheet1) that is currently active and add the new sheet in the background.
Thanks
At first, things look simple but there are a few things to consider:
There could be more sheets selected before running the code
The selected sheet(s) could be Chart sheet(s)
The Workbook can be protected
You might not want to set Application.ScreenUpdating = True at the end of the method because you might be running this from within another method that still needs it off
Restoring selection can only happen if the proper window is activated
You could use this method:
Sub AddWorksheet(ByVal targetBook As Workbook, ByVal sheetname As String)
Const methodName As String = "AddWorksheet"
'Do input checks
If targetBook Is Nothing Then
Err.Raise 91, methodName, "Target Book not set"
ElseIf sheetname = vbNullString Then
Err.Raise 5, methodName, "Sheet name cannot be blank"
ElseIf Len(sheetname) > 31 Then
Err.Raise 5, methodName, "Sheet name cannot exceed 31 characters"
Else
Dim arrForbiddenChars() As Variant
Dim forbiddenChar As Variant
arrForbiddenChars = Array(":", "\", "/", "?", "*", "[", "]")
For Each forbiddenChar In arrForbiddenChars
If InStr(1, sheetname, forbiddenChar) > 0 Then
Err.Raise 5, methodName, "Sheet name cannot contain characters: : \ / ? * [ or ]"
End If
Next forbiddenChar
End If
Dim alreadyExists As Boolean
'Check if a sheet already exists with the desired name
On Error Resume Next
alreadyExists = Not (targetBook.Sheets(sheetname) Is Nothing)
On Error GoTo 0
If alreadyExists Then
MsgBox "A sheet named <" & sheetname & "> already exists!", vbInformation, "Cancelled" 'Can remove
Exit Sub
End If
'Check if Workbook is protected
If targetBook.ProtectStructure Then
'Maybe write code to ask for password and then unprotect
'
'
'Or simply exit
MsgBox "Workbook is protected. Cannot add sheet", vbInformation, "Cancelled"
Exit Sub
End If
Dim bookActiveWindow As Window
Dim appActiveWindow As Window
Dim selectedSheets As Sheets
Dim screenUpdate As Boolean
Dim newWSheet As Worksheet
'Store state
Set bookActiveWindow = targetBook.Windows(1)
Set appActiveWindow = Application.ActiveWindow 'Can be different from the target book window
Set selectedSheets = bookActiveWindow.selectedSheets
screenUpdate = Application.ScreenUpdating
'Do main logic
screenUpdate = False
If bookActiveWindow.Hwnd <> Application.ActiveWindow.Hwnd Then
bookActiveWindow.Activate
End If
If selectedSheets.Count > 1 Then selectedSheets(1).Select Replace:=True
Set newWSheet = targetBook.Worksheets.Add
newWSheet.Name = sheetname
'Restore state
selectedSheets.Select Replace:=True
If appActiveWindow.Hwnd <> Application.ActiveWindow.Hwnd Then
appActiveWindow.Activate
End If
Application.ScreenUpdating = screenUpdate
End Sub
If you want the book containing the code then you can call with:
Sub Test()
AddWorksheet ThisWorkbook, "BLANK"
End Sub
or, if you want the currently active book (assuming you are running this from an add-in) then you can call with:
Sub Test()
AddWorksheet ActiveWorkbook, "BLANK"
End Sub
or any other book depending on your needs.
Just remember who was active:
Sub ytrewq()
Dim wsh As Worksheet, SheetsExist As Boolean
Set wsh = ActiveSheet
Application.ScreenUpdating = False
SheetExists = False
For Each ws In Worksheets
If ws.Name = "BLANK" Then
SheetExists = True
End If
Next ws
If Not SheetExists Then
Sheets.Add
ActiveSheet.Name = "BLANK"
End If
wsh.Activate
Application.ScreenUpdating = False
End Sub
I modified code from Copy worksheet into different workbook replacing current data.
If I deselect range or I have selected different cell than A1, code falls into 1004 error.
Sub TG_update()
Dim wb1 As Workbook, wb2 As Workbook, ws1Format As Worksheet, ws2Format As Worksheet, ws3Format As Worksheet, ws4Format As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open("[add your path.xlsx]")
Set ws1Format = wb1.Sheets("SheetA1")
Set ws2Format = wb2.Sheets("SheetB1")
Set ws3Format = wb1.Sheets("SheetA2")
Set ws4Format = wb2.Sheets("SheetB2")
'' Copy the cells of the "Format" worksheet.
ws2Format.Cells.Copy
'' Paste cells to the sheet "Format".
wb1.Sheets("SheetA1").Paste
ws4Format.Cells.Copy
wb1.Sheets("SheetB1").Paste
wb2.Close False 'remove false if you want to be asked if the workbook shall be saved.
wb1.Sheets("Store").Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Date successfully updated"
End Sub
Please try this code. Instead of copying and pasting millions of blank cells this code copies the worksheet from the source and pastes it to the workbook with the code. If the action is successful the old sheet is deleted. The final report alerts about errors if sheets weren't found.
Sub TG_update()
' 016
Dim Wb As Workbook ' ThisWorkbook
Dim WbS As Workbook ' Source
Dim Ffn As String ' Full FileName
Dim Ws As Worksheet
Dim TabName() As String
Dim i As Integer ' TabName index
Dim n As Integer ' tab counter
Set Wb = ThisWorkbook
' specify the workbook to be copied from: Full path and name
Ffn = "F:\AWK PC\Drive E (Archive)\PVT Archive\Class 1\1-2018 (Jan 2020)\TXL 180719 Z Distance.xlsm"
' enumerate the sheet names in CSV format (sheets must exist in Wb)
TabName = Split("SheetA1,SheetB1", ",")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set WbS = Workbooks.Open(Ffn)
For i = 0 To UBound(TabName)
On Error Resume Next ' suppress error if worksheet isn't found
WbS.Worksheets(TabName(i)).Copy After:=Wb.Worksheets(Wb.Worksheets.Count)
If Err.Number = 0 Then
n = n + 1
End If
Next i
WbS.Close SaveChanges:=False
On Error GoTo 0
For i = 0 To UBound(TabName)
For Each Ws In Wb.Worksheets
If InStr(Ws.Name, TabName(i) & " (") = 1 Then
Wb.Worksheets(TabName(i)).Delete
Ws.Name = TabName(i)
End If
Next Ws
Next i
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox n & " of " & i & " worksheets were successfully updated.", _
vbInformation, "Action report"
End Sub
Creative names like Wb1, Wb2, Ws1, Ws2, SheetA1, SheetA2 represent the punishment imaginative programmers inflict on those who come after them to correct their hastily concocted code. Give your VBA project a better reputation by bestowing names on your two worksheets that permit their identification.
I am working on a Userform that will copy a specific sheet from Workbook A and paste it into Workbook B (essentially archiving that data). The Userform presents the user with a combo-box dropdown to select the sheet name to be copied. I receive a subscript out of range error however when using the sheets.copy command. Here is my code with names modified for ease of reading:
Dim ws as Worksheet
Dim WorkbookA as Workbook
Dim WorkbookB as Workbook
Dim ComboBoxValue as String
Set WorkbookA as ActiveWorkbook
Set WorkbookB as Workbook.Open("C:File Path Here")
With ThisWorkbook
For Each ws In Application.ActiveWorkbook.Worksheets
If ws.Name = UserForm1.ComboBox1.Text Then
ComboBoxValue = ws.Name
Worksheets(ComboBoxValue).Copy _
After:=Workbooks("Workbook B.xlsm").Sheets(Sheets.Count)
' Run-Time 9 Subscript Out of Range Error occurs on line above ^
ActiveSheet.Name = UserForm1.ComboBoxSelection.Text
WorkbookB.Save
WorkbookB.Close
WorkbookA.Activate
Application.CutCopyMode = False
End If
Next ws
End With
The root of your error is improper refenceing of the workbook. There are a lot of other issues, too.
Unnecassary reference to ThisWorkbook
Unnecassary loop through all worksheets
Unnecassary renaming of copied sheet
Unnecassry / incorrect references to the ActiveWorkbook and ActiveSheet
No Error Handling
Improper indenting
Your code, refactored. This is written as a button click event in the UserForm. Update to suit your needs.
Option Explicit
Const ArchiveFilePath As String = "C:\Path\To\ArchiveBook.xlsx"
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim WorkbookA As Workbook
Dim WorkbookB As Workbook
Dim wsName As String
Application.ScreenUpdating = False
Set WorkbookA = ActiveWorkbook
wsName = UserForm1.ComboBox1.Text
If wsName = vbNullString Then Exit Sub
On Error Resume Next 'Handle possibility that Open fails
Set WorkbookB = Workbooks.Open(ArchiveFilePath)
On Error GoTo 0
If WorkbookB Is Nothing Then
MsgBox "Failed to open " & ArchiveFilePath, vbOKOnly, "Error"
Exit Sub
End If
'Check if specified ws already exists in WorkbookB
Set ws = GetWorksheet(WorkbookB, wsName)
If Not ws Is Nothing Then
' Sheet already exists. What now?
MsgBox "Sheet " & wsName & " already exists in " & WorkbookB.Name & ". What now?", vbOKOnly, "Error"
WorkbookB.Close
Exit Sub
End If
Set ws = GetWorksheet(WorkbookA, wsName)
If ws Is Nothing Then
MsgBox "Sheet " & wsName & " does not exist in " & WorkbookA.Name, vbOKOnly, "Error"
WorkbookB.Close
Exit Sub
End If
ws.Copy After:=WorkbookB.Sheets(WorkbookB.Sheets.Count)
WorkbookB.Save
WorkbookB.Close
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Private Function GetWorksheet(wb As Workbook, wsName As String) As Worksheet
On Error GoTo EH
Set GetWorksheet = wb.Worksheets(wsName)
EH:
End Function
Change Sheets(Sheets.Count) to Sheets(Workbooks("Workbook B.xlsm").Sheets.Count)
In this context, Sheets(Sheets.Count) is referring to your source workbook object, so you must specify to count the sheets in the other book.
I had a requirement which is in excel macro. Here is the scenario :
I have 2 workbooks, Say A and B
Workbook "A" contains, sheet 1, sheet2 and sheet3, Workbook "B" contains sheet4
Now i need to compare Workbook "B" with Workbook A. If a sheet exist in Workbook "A" which is not in Workbook "B" (Here Sheet1, Sheet2, Sheet3) then i need to add these 3 sheets to Workbook "B"
So finally, B workbook should contain : Sheet 1, sheet 2, sheet 3 and sheet 4.
Tried below code but its not working.
Set act = ThisWorkbook
path = Sheet1.TextBox1.Text
Set owb = Workbooks.Open(Filename:=path)
For Each ws In ThisWorkbook.Worksheets
a = ws.Name
For Each ws1 In owb.Worksheets
If ws1.Name = a Then
MsgBox "Found"
Else
Set wsnew = owb.Sheets.Add
wsnew.Name = a
End If
Next ws1
Next ws
Rather than check each worksheet you could try and set a reference to it - if the reference is set then the sheet exists, if it throws an error then it doesn't exist.
I'd use a separate function to return TRUE/FALSE on the sheet existing - one of the few times that I'd use On Error Resume Next to ignore any errors.
Public Sub CopySheets()
Dim wrkBk As Workbook
Dim wrkSht As Worksheet
Dim wrkShtNew As Worksheet
Set wrkBk = Workbooks("Book2")
For Each wrkSht In ThisWorkbook.Worksheets
If Not WorkSheetExists(wrkSht.Name, wrkBk) Then
Set wrkShtNew = wrkBk.Worksheets.Add
wrkShtNew.Name = wrkSht.Name
Else
MsgBox wrkSht.Name & " exists.", vbOKOnly + vbInformation
End If
Next wrkSht
End Sub
Public Function WorkSheetExists(SheetName As String, Optional wrkBk As Workbook) As Boolean
Dim wrkSht As Worksheet
If wrkBk Is Nothing Then
Set wrkBk = ThisWorkbook
End If
On Error Resume Next
Set wrkSht = wrkBk.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
I am wanting to have a button open a userform with a list of all open Workbooks. The user selects the workbook they want and the code copies data from a fixed range in the current workbook and pastes it into a fixed range in the user selected workbook.
While searching around I found this code, that works similarly but copies from the selected workbook and pastes into the current one.
Option Explicit
Const PSWD = "atari"
Private Sub CancelButton_Click()
Unload Me
End Sub
Private Sub CopyPasteButton_Click()
ActiveSheet.Unprotect Password:=PSWD
'This code will be executed when the "Copy" button is clicked on the userform.
Dim wsData As Worksheet
Dim rCopy As Range
Dim CopyRw As Long
Set wsData = ThisWorkbook.Sheets("SALES Details")
With Application
.DisplayAlerts = False
.ScreenUpdating = True
With wsData
.Unprotect PSWD
CopyRw = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
On Error GoTo exit_err
With Workbooks(Me.ListBox1.Value).Sheets("Master Sheet")
Set rCopy = .Cells(10, 1).CurrentRegion
Set rCopy = rCopy.Offset(1, 0).Resize(rCopy.Rows.Count - 1, 40)
rCopy.Copy ThisWorkbook.Sheets("SALES Details").Cells(CopyRw, 1)
End With
Unload Me
exit_err:
wsData.Protect Password:=PSWD
.DisplayAlerts = True
.ScreenUpdating = True
.CutCopyMode = False
End With
End Sub
Private Sub UserForm_Activate()
'Populate list box with names of open workbooks, excluding main workbook.
Dim wb As Workbook
For Each wb In Workbooks
If wb.Name <> ThisWorkbook.Name Then ListBox1.AddItem wb.Name
Next wb
End Sub
This code works great, for what it does. I have been trying to edit it without luck. How can I edit this to reverse the direction and have it copy from a fixed range in the current sheet (A50:J57) to a fixed range on the user selected sheet (A4:J11)?
I think this should work. Of course you have to adapt the sheet names in code.
Private Sub CopyPasteButton_Click()
Dim mySheet As Worksheet, otherSheet As Worksheet
On Error GoTo exit_err
Application.DisplayAlerts = False
Set mySheet = ThisWorkbook.Sheets("SheetXYZ")
Set otherSheet = Workbooks(Me.ListBox1.Value).Sheets("SheetABC")
mySheet.Range("A50:J57").Copy Destination:=otherSheet.Range("A4:J11")
exit_err:
Application.DisplayAlerts = True
End Sub
UPDATE
For copying the values and not the formulas of the range use this code instead of the Copy function:
mySheet.Range("A50:J57").Copy
otherSheet.Range("A4:J11").PasteSpecial xlPasteValuesAndNumberFormats
For further options of the PasteSpecial function see the documentation.