I am trying to copy sheet1 of workbook name Source.xlsm to workbook name s.xlsx. And then rename the copied sheet to a column value say D1.
My code copies the sheet properly but while renaming it is giving error.
Instead of displaying message name already exits it is going to else part and giving error: Run-time error '1004': Can not rename a sheet to name as of another sheet. And this line Sheet.Name = range("D1") is highlighted.
Plese correct me what i am doing wrong.
My Code is:
Sub savesheet()
Dim sPath As String
Dim wbPath1 As Workbook
Dim wsName As String
sPath = Application.ActiveWorkbook.Path & "\s\s.xlsx"
Set wbPath1 = Workbooks.Open(sPath)
Workbooks("Source.xlsm").Sheets("Sheet1").Copy After:=wbPath1.Sheets(1)
'For Each Sheet In ActiveWorkbook.Sheets
For Each Sheet In Workbooks("s.xlsx").Sheets
If Sheet.Name = range("D1") Then
MsgBox "name already exits"
Exit Sub
Else
Sheet.Name = range("D1")
End If
Next
End Sub
Changed the code and issues resolved. Below is the code for reference:
Sub movesheet3()
Dim name As String
Dim sPath As String
Dim wbPath1 As Workbook
name = Workbooks("Source.xlsm").Sheets("Sheet1").range("D1").value
sPath = Application.ActiveWorkbook.Path & "\s\s.xlsx"
Set wbPath1 = Workbooks.Open(sPath)
wbPath1.Activate
'Workbooks("Source.xlsm").Sheets("Sheet1").Copy After:=wbPath1.Sheets(Sheets.Count)
For i = 1 To (Worksheets.Count)
If ActiveWorkbook.Sheets(i).name = name Then
MsgBox "Sheet name already exist. GO back to the sheet and enter valid name in D1 cell"
Exit Sub
End If
Next
Workbooks("Source.xlsm").Sheets("Sheet1").Copy After:=wbPath1.Sheets(Sheets.Count)
Sheets(ActiveSheet.name).name = name
ActiveWorkbook.Close True
End Sub
Thanks for the help everyone....Cheers
Related
I am writing a VBA code where I need to find if sheet name given by user through inputbox is available or not in a workbook containing many sheets.
But if the sheet name is not available then the inputbox pops up again to enter the sheet name so it can search again.
I have written 1st part of the code which is working fine but I need help with the 2nd part(if the sheet name is not available). Let me know if this is possible in for loop or I have to use other loop?
Sub callbyinputbox()
Dim pendworkbook As Workbook
Dim sht As Worksheet
Dim entername As String
Set pendworkbook = Workbooks("pend_app_new.xlsx")
entername = InputBox("Enter name", "Search Sheet")
For Each sht In pendworkbook.Worksheets
If sht.Name = entername Then
pendworkbook.Sheets(entername).Activate
Exit Sub
End If
Next sht
MsgBox ("You entered " & entername & vbNewLine & "Sheet by this name is not available")
end sub
Here is your code:
entername = InputBox("Enter name", "Search Sheet")
For Each sht In pendworkbook.Worksheets
If sht.Name = enterDate Then
pendworkbook.Sheets(entername).Activate
Exit Sub
End If
Next sht
You store the response from the user in a variable: entername.
You then loop through all the sheets and check if the name matches a variable called enterDate.
Change this to entername and it will then have something to match against, and the If block will run.
Check out using Option Explicit - this would have highlighted this issue for you.
UPDATE:
This is probably breaking an unwritten rule somewhere, but a simple Do Until False loop, which will permanently run (until the Exit Sub condition is reached and breaks the loop) will keep asking until a valid sheetname is input.
Alternatively, you could use a For.. Next loop. That way, you could set a maximum number of prompts before giving up..
Note: I have made this comparison case insensitive - to give the user a better chance of inputting a correct sheet name.
Sub callbyinputbox()
Dim pendworkbook As Workbook
Dim sht As Worksheet
Dim entername As String
Set pendworkbook = Workbooks("pend_app_new.xlsx")
Do Until False
entername = InputBox("Enter name", "Search Sheet")
For Each sht In pendworkbook.Worksheets
If LCase(sht.Name) = LCase(entername) Then
pendworkbook.Sheets(entername).Activate
Exit Sub
End If
Next sht
MsgBox ("You entered " & entername & vbNewLine & "Sheet by this name is not available")
Loop
End Sub
All the while, I have attempted to correct your code and explain the reasoning. For that reason, I have tried to keep as much of your code as possible and just steer you toward your goal. If I was writing this from scratch, I would use the approach suggested by Ike.
To handle all usecases (no input given, existing sheetname given, non-existing sheetname given) - you can use this code:
Public Sub activateSheetByUserInput()
Dim pendworkbook As Workbook
Dim sht As Worksheet
Dim entername As String
Set pendworkbook = Workbooks("pend_app_new.xlsx")
retry:
entername = InputBox("Enter name", "Search Sheet")
If LenB(entername) = 0 Then
Exit Sub
ElseIf tryGetWorksheetByName(pendworkbook, entername, sht) = True Then
sht.Activate
Else
'give the user the option to cancel the process
If vbCancel = MsgBox("You entered " & entername & vbNewLine & "Sheet by this name is not available", vbCritical + vbRetryCancel) Then
Exit Sub
Else
GoTo retry
End If
End If
End Sub
'function returns true if worksheet was found - plus the ws itself
Private Function tryGetWorksheetByName(ByVal wb As Workbook, ByVal strName, ByRef sht As Worksheet) As Boolean
On Error Resume Next 'one of the rare cases where it is valid to use on error resume next
Set sht = wb.Worksheets(strName)
If Err = 0 Then tryGetWorksheetByName = True
On Error GoTo 0
End Function
Another way would be to supply a list of valid sheet names and ask them to select one.
Add a userform and place a listbox on it. I've left the default names, but would be better to name the controls to something relevant.
Add this code to the form:
Private Sub UserForm_Initialize()
Dim pendworkbook As Workbook
Set pendworkbook = Workbooks("pend_app_new.xlsx")
Dim shts() As Variant
ReDim shts(0 To 0, 0 To pendworkbook.Worksheets.Count - 1)
Dim x As Long
For x = 1 To pendworkbook.Worksheets.Count
shts(0, x - 1) = pendworkbook.Worksheets(x).Name
Next x
ListBox1.List = Application.WorksheetFunction.Transpose(shts)
End Sub
Private Sub ListBox1_Click()
MsgBox "You clicked " & ListBox1.Value
End Sub
I want a user to be able to select a cell with a sheet name in it, and then have a single macro button go to that worksheet. How do I get VBA to use the contents of the selected cell?
I have one setup to go back to the "Summary" worksheet, but want to let users go quickly to a selected sheet without having to create a different macro for each sheet as the user will be adding sheets to the workbook over time.
Sub Return_to_Summary()
' Return_to_Summary Macro
Sheets("Summary").Select
End Sub
You might also want to add in some validation or error checking.
Public Sub Return_to_Summary()
Dim sName As String
Dim oSht As Worksheet
Dim bFound As Boolean
bFound = False
sName = ActiveCell.Text
For Each oSht In ActiveWorkbook.Sheets
If oSht.name = sName Then
bFound = True
Exit For
End If
Next
If bFound = True Then
Sheets(ActiveCell.Text).Activate
Else
MsgBox "This worksheet (" & sName & ") cannot be found. Check the spelling and capitalization."
End If
End Sub
I have a workbook with one worksheet Sheet1. On that Sheet I have one table with its default name Table1.
When I copy the worksheet Right-Click > Move or Copy in the same workbook I get sheet Sheet1 (2).
The Table on this sheet is automatically named Table13.
I do some processing in that copied sheet and subsequently remove it. Leaving the workbook with only its original Sheet1.
Each time I make a copy of Sheet1 the table in the copied sheet is incremented by one.
Also if I remove the sheet and add a new one. It keeps incrementing.
I use the workbook and Sheet1 as a template and I create via a macro a lot of copies.
The new Table Name has now Incremented to Table21600.
I found out that Excel will give an overflow when I reach approximately Table21650.
So, I need a way to reset the Name counter of the added table.
Does anyone know how to achieve this?
You can access (and alter) the names of each table ("ListObject") from your macro-code as shown in this example:
Sub ListAllListObjectNames()
Dim wrksheet As Worksheet
Dim lstObjct As ListObject
Dim count As Integer
count = 0
For Each wrksheet In ActiveWorkbook.Worksheets
For Each lstObjct In wrksheet.ListObjects
count = count + 1
lstObjct.Name = "Table_" & CStr(count)
Debug.Print wrksheet.Name, ": ", lstObjct.Name
Next
Next
End Sub
Reset Table 'Counter'
Allthough the 'counter' will not stop incrementing, when you close
the workbook and open it the next time, it will again start from
Table13.
In the Immediate window CRTL+G you will see the table name
before and after the renaming. When done testing just out comment the
lines containing Debug.Print.
The First Code
' Copies a sheet and renames all its tables.
Sub CopySheetWithTable(Optional SheetNameOrIndex As Variant = "Sheet1", _
Optional NewTableName As String = "Tbl")
Dim MySheet As Worksheet
Dim MyCopy As Worksheet
Dim MyTable As ListObject
Dim i As Long
Set MySheet = ThisWorkbook.Worksheets(SheetNameOrIndex)
'MySheet.Copy MySheet ' Before e.g. Sheet1)
MySheet.Copy , MySheet ' After e.g. Sheet1
Set MyCopy = ActiveSheet
For Each MyTable In MyCopy.ListObjects
i = i + 1
Debug.Print "Old Table Name = " & MyTable.Name
MyTable.Name = NewTableName & i
Debug.Print "Old Table Name = " & MyTable.Name
Next
End Sub
Usage
Copy the previous and the following sub into a module. Run the
following sub to copy a new worksheet. Adjust if you want it before
or after the sheet to be copied.
You don't need to copy the worksheet manually anymore.
The Second Code
' You can create a button on the worksheet and use this one-liner in its code.
Sub CopySheet()
CopySheetWithTable ' Default is CopySheetWithTable "Sheet1", "Tbl"
End Sub
Delete all Sheets After Worksheet
This is just a testing tool.
' Deletes all sheets after the selected sheet (referring to the tab order).
Sub DeleteSheetsAfter(DeleteAfterSheetNameOrIndex As Variant) 'Not tested.
Dim LastSheetNumber As Long
Dim SheetsArray() As Variant
Dim i As Long
' Try to find the worksheet in the workbook containing this code.
On Error Resume Next
LastSheetNumber = _
ThisWorkbook.Worksheets(DeleteAfterSheetNameOrIndex).Index
If Err.Number <> 0 Then
MsgBox "There is no Sheet '" & DeleteAfterSheetNameOrIndex & "' " _
& "in (this) workbook '" & ThisWorkbook.Name & "'."
Exit Sub
End If
With ThisWorkbook
ReDim SheetsArray(.Sheets.Count - LastSheetNumber - 1)
For i = LastSheetNumber + 1 To .Sheets.Count
SheetsArray(i - LastSheetNumber - 1) = i
Next
End With
Application.DisplayAlerts = False
ThisWorkbook.Sheets(SheetsArray).Delete
Application.DisplayAlerts = True
MsgBox "Deleted " & UBound(SheetsArray) & " worksheets after worksheet '" _
& ThisWorkbook.Worksheets(DeleteAfterSheetNameOrIndex).Name & "'.", _
vbInformation, "Delete Successful"
End Sub
Sub DeleteAfter()
DeleteSheetsAfter "Sheet1"
End Sub
I have a spreadsheet with a small Subroutine in it that should do three things when the tab for the sheet "Template" is clicked:
1. make a copy of the "Template" sheet and place it before the original "Template" sheet
2. change the name of the copied sheet to be today's date (10-13-2016)
3. change the contents of cell B1 to be today's date (Thursday, Oct 13, 2016)
The code listed below does these things sort of. The two things I need help on is this:
1. to get the sheet to copy I have to click another sheet and then click back on the "Template" sheet. I'd like to be able to just click the "Template" tab and have it create the copy, even if the "Template" sheet is already the active sheet.
2. for some reason the VBA code prevents me from deleting the tab that is created when you click the "Template" tab.
Private Sub Worksheet_Activate()
Application.EnableEvents = False
If ActiveSheet.Name = "Template" Then
Worksheets("Template").Copy before:=Worksheets("Template")
ActiveSheet.Range("B2").Select
ActiveCell.FormulaR1C1 = Format(Date, "dddd, mmm d, yyyy")
ActiveSheet.Name = Format(Date, "mm-dd-yyyy")
End If
Application.EnableEvents = True
End Sub
I know this is probably very simple but I haven't been able to find any reference to this behavior anywhere. Any and all help will be much appreciated.
you wouldn't use Worksheet_Activate() because it would be copied along with the worksheets copies, thus having copied worksheets generate other worksheets
so you want to use Workbook_SheetActivate() event handler
even then, you must be aware that upon deleting a sheet just preceeding "Template", the active sheet becomes "Template" (i.e.the next one) thus activating the cloning procedure and making it seem as if "VBA code prevents" you "from deleting the tab"
then type this code in ThisWorkBook code pane:
Option Explicit
Dim nextShtName As String
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim newName As String
If nextShtName = "Template" Then
nextShtName = ""
Else
If Sh.Name = "Template" Then
newName = Format(Date, "mm-dd-yyyy")
If GetSheet(newName) Is Nothing Then
Application.EnableEvents = False
On Error GoTo exitsub
Sh.Copy before:=Worksheets("Template")
With ActiveSheet
.Range("B2").FormulaR1C1 = Format(Date, "dddd, mmm d, yyyy")
.Name = newName
End With
exitsub:
Application.EnableEvents = True
Else
MsgBox "sheet '" & newName & "' already in this workbook", vbInformation
End If
End If
End If
End Sub
Function GetSheet(shtName As String) As Worksheet
On Error Resume Next
Set GetSheet = Worksheets(shtName)
End Function
Private Sub Workbook_SheetBeforeDelete(ByVal Sh As Object)
Dim i As Long
For i = 1 To Worksheets.Count
If Worksheets(i).Name = Sh.Name Then Exit For
Next i
nextShtName = Worksheets(i + 1).Name
End Sub
The script below loops through to create tabs and name the tab then it will place the tab name in cell B3. It's been working fine but now gives the catch all runtime error 1004. At the bottom of my script it renames the tab. This is where the error is happening. It's creating the tabs but fails to rename it. Can anyone please suggest another way to rename the tab in this script. The error is on Sheets(Name).Select.
Public Sub CreateTabs()
Sheets("TABlist").Select
' Determine how many Names are on Data sheet
FinalRow = Range("A65000").End(xlUp).Row
' Loop through each Name on the data sheet
For x = 1 To FinalRow
LastSheet = Sheets.Count
Sheets("TABlist").Select
Name = Range("A" & x).Value
' Make a copy of FocusAreas and move to end
Sheets("TABshell").Copy After:=Sheets(LastSheet)
' rename the sheet and put name in Cell B2
Sheets(LastSheet + 1).Name = Name
Sheets(Name).Select
Range("B3").Value = Name
Next x
End Sub
It is very important to write code that is robust. It shouldn't fail in any scenario. For example appropriate error handling should be done and variables declared.
I would recommend reading this.
Topic: To ‘Err’ is Human
Link: http://www.siddharthrout.com/2011/08/01/to-err-is-human/
Now back to your code. I have amended the code. Try this. I have also commented the code so you shouldn't have any difficulty understanding it :) Still if you do, just give a shout.
Code
Option Explicit
Public Sub CreateTabs()
Dim ws As Worksheet
Dim FinalRow As Long, x As Long, LastSheet As Long
Dim name As String
On Error GoTo Whoa
Application.ScreenUpdating = False
Set ws = Sheets("TABlist")
FinalRow = ws.Range("A" & Rows.Count).End(xlUp).Row
For x = 1 To FinalRow
LastSheet = Sheets.Count
'~~> Get the name for the new sheet
name = ws.Range("A" & x).Value
'~~> Check if you already have a sheet with that name or not
If Not SheetExists(name) Then
Sheets("TABshell").Copy After:=Sheets(LastSheet)
ActiveSheet.name = name
Range("B3").Value = name
End If
Next x
LetsContinue:
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
'~~> Function to check if sheet exists
Function SheetExists(wst As String) As Boolean
Dim oSheet As Worksheet
On Error Resume Next
Set oSheet = Sheets(wst)
On Error GoTo 0
If Not oSheet Is Nothing Then SheetExists = True
End Function
Each worksheet name in an Excel workbook needs to be unique.
As a quick fix to see what name is causing the error, try using this code and then check the sheet names against your list.
Public Sub CreateTabs()
On Error Resume Next
Sheets("TABlist").Select
' Determine how many Names are on Data sheet
FinalRow = Range("A65000").End(xlUp).Row
' Loop through each Name on the data sheet
For x = 1 To FinalRow
LastSheet = Sheets.Count
Sheets("TABlist").Select
Name = Range("A" & x).Value
' Make a copy of FocusAreas and move to end
Sheets("TABshell").Copy After:=Sheets(LastSheet)
' rename the sheet and put name in Cell B2
Sheets(LastSheet + 1).Name = Name
Sheets(Name).Select
Range("B3").Value = Name
Next x
On Error GoTo 0
End Sub
I got lost amid all the selects so I am not sure why your original code failed. I edited your question to make it more readable but only I can see the improvement until my edit it peer reviewed.
I have deleted all your select statements. Comments starting '## explain why I have made other changes.
Option Explicit
Public Sub CreateTabs()
Dim CrntRow As Long '## I like names I understand
Dim FinalRow As Long
Dim Name As String
' Determine how many Names are on Data sheet
'## Row.Count will work for any version of Excel
FinalRow = Sheets("TABlist").Cells(Rows.Count, "A").End(xlUp).Row
' Loop through each Name on the data sheet
For CrntRow = 1 To FinalRow
Name = Sheets("TABlist").Range("A" & CrntRow).Value
' Make a copy of FocusAreas and move to end
Sheets("TABshell").Copy After:=Sheets(Worksheets.Count)
' rename the sheet and put name in Cell B2
'## The copy will be the active sheet
With ActiveSheet
.Name = Name
.Range("B3").Value = Name
End With
Next CrntRow
End Sub