My goal is to control which worksheet tabs get renamed.
Sub RenameSheets()
Dim I As Long
On Error Resume Next
xTitleld = "Rename Worksheets"
newName = Application.InputBox("Name",xTitleld,"",Type:=2)
For i = 1 To Application.Sheets.Count
If Sheets(i).Name <>"Signature" AND WS.Name <> "Invoice" AND WS.Name `<> "Cover" _
Then Sheeets (i).Name = newName & i
Next
End Sub
I want the worksheet tabs named AR1, AR2, etc. be changed.
I have many other sheets in the workbook. The code is changing all worksheet tabs.
You can try using Select Case ThisWorkbook.Sheets(i).Name, it will simplify and shorten your code a lot. You can also add more names in the future.
Modified Code
Option Explicit
Sub RenameSheets()
Dim i As Long
Dim newName As String, xTitleld As String
xTitleld = "Rename Worksheets"
newName = Application.InputBox("Name", xTitleld, "", Type:=2)
For i = 1 To ThisWorkbook.Sheets.Count
Select Case ThisWorkbook.Sheets(i).Name
Case "Signature", "Invoice", "Cover"
' Do Nothing
Case Else
ThisWorkbook.Sheets(i).Name = newName & i
End Select
Next i
End Sub
You can test whether the characters "AR" appear at the beginning of the name.
Option Explicit
Sub RenameSheets_AR()
Dim I As Long
Dim xTitleld As String
Dim newName As String
' Use only in specific circumstances
'On Error Resume Next
' To increase debugging success see http://www.cpearson.com/excel/errorhandling.htm
xTitleld = "Rename Worksheets"
keyName:
newName = Application.InputBox("Name", xTitleld, "", Type:=2)
If newName = "" Then Exit Sub
For I = 1 To Application.Sheets.Count
If Left(Sheets(I).Name, 2) = "AR" Then
Sheets(I).Name = newName & I
End If
Next
End Sub
Related
I am new to VBA.
Thank you for your time. I have been Googling for 2 days and always get an error.
I have two sheets
Projects ( where I will store project names) and
Template (where new projects will be created using the "template" sheet)
I have 2 issues I am trying to solve :
How do I copy the format on an active sheet including conditional formatting and column width. PasteSpecial already copies all the colour design but not the column width/conditional formatting
When I run the code it creates a new sheet called Project Name,not sure where that is coming from.
This is the code I am using:
Sub Copy()
Sheets("Template").Range("A1:O100").Copy
ActiveSheet.PasteSpecial
End Sub
<<<<<<<<<<<<<<<<<<<<<<
I want to generate a project name, make sure it does not exist(no duplicate), open a new sheet and copy the template from "template".
The full codes is:
RunAll()
CreateProjectName
CreateNewTab
CopyPaste
End Sub
Dim AddData As Range
Dim AddName As String
Set AddData = Cells(Rows.Count, 4).End(xlUp).Offset(1, 0)
AddName = InputBox("Enter Project Name do not input manually", "Project Monitor")
If AddName = "" Then Exit Sub
AddData.Value = AddName
AddData.Offset(0, 1).Value = Now
End Sub
Function SheetCheck(sheet_name As String) As Boolean
Dim ws As Worksheet
SheetCheck = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = sheet_name Then
SheetCheck = True
End If
Next
End Function
Sub CreateNewTab()
Dim sheets_count As Integer
Dim sheet_name As String
Dim i As Integer
sheet_count = Range("D3:D1000").Rows.Count
For i = 1 To sheet_count
sheet_name = Sheets("Projects").Range("D3:D1000").Cells(i, 1).Value
If SheetCheck(sheet_name) = False And sheet_name <> "" Then
Worksheets.Add(After:=Sheets("Projects")).Name = sheet_name
End If
Next i
End Sub
Sub CopyPaste()
Sheets("Template").Range("A1:o100").Copy
ActiveSheet.PasteSpecial
End Sub
Option Explicit
Sub AddProject()
Dim ws As Worksheet, NewName As String
NewName = InputBox("Enter Project Name do not input manually", "Project Monitor")
' checks
If NewName = "" Then
MsgBox "No name entered", vbCritical
Exit Sub
Else
' check sheet not existing
For Each ws In ThisWorkbook.Sheets
If UCase(ws.Name) = UCase(NewName) Then
MsgBox "Existing Sheet '" & ws.Name & "'", vbCritical, "Sheet " & ws.Index
Exit Sub
End If
Next
End If
' check not existing in list
Dim wb As Workbook, n As Long, lastrow As Long, v
Set wb = ThisWorkbook
With wb.Sheets("Projects")
lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row
v = Application.Match(NewName, .Range("D1:D" & lastrow), 0)
' not existing add to list
If IsError(v) Then
.Cells(lastrow + 1, "D") = NewName
.Cells(lastrow + 1, "E") = Now
Else
MsgBox "Existing Name '" & NewName & "'", vbCritical, "Row " & v
Exit Sub
End If
End With
' create sheet
n = wb.Sheets.Count
wb.Sheets("Template").Copy after:=wb.Sheets(n)
wb.Sheets(n + 1).Name = NewName
MsgBox NewName & " added as Sheet " & n + 1, vbInformation
End Sub
I' am looking for a code to check Sheet names initially like A, B, C. If sheet A exist then it should run the code which is goto A1: else it should go to B and check if Sheet B exist, if sheet B exist then it should run code below B1, Same way for sheet C as well.
Ex:
For I = 1 to worksheets.count
If Sheets(i).Name = "A" Then
GoTo A1
Else
GoTo B
End If
Next I
I think it can be solved by using ElseIf or Select Case.
Please try with the following 2 cases.
Dim i As Integer
For i = 1 To Worksheets.Count
Select Case Sheets(i).Name
Case "A"
' Coding for "GoTo A1"
Case "B"
' Coding for "GoTo B1"
Case "C"
' Coding for "GoTo C1"
...
End Select
Next i
Or
Dim i As Integer
For i = 1 To Worksheets.Count
If Sheets(i).Name = "A" Then
' Coding for "GoTo A1"
ElseIf Sheets(i).Name = "B" Then
' Coding for "GoTo B1"
ElseIf Sheets(i).Name = "C" Then
' Coding for "GoTo C1"
Else
...
End If
Next i
If you have a specific macro you want to run on each sheet and you want to trigger all of them to run at once, you can organize it like so:
Sub Main()
Call SheetA_Macro
Call SheetB_Macro
Call SheetC_Macro
End Sub
If you have a lot of sheets you can automate the calling of these macros by naming them all the same thing and placing them into the sheet's code module, which would let you call them in this way:
Sub Main()
Dim Sht As Worksheet
For Each Sht In ThisWorkbook.Worksheets
Call ThisWorkbook.Sheets(Sht.Name).MySheetSpecificMacro
Next Sht
End Sub
If you have an unknown sheet and you want to call only that specific sheets macro, then you will want to do it like above but without the loop.
Call ThisWorkbook.Sheets(MyUnknownSheetObject.Name).MySheetSpecificMacro
Remember that the macros must be placed into the sheet's code module and should all be named the same thing.
Worksheet Related Code
Writes the list of worksheet names to an array.
Loops through the array attempting to find an existing worksheet using the WorksheetExists function.
Continues with the worksheet that exists (if any).
Option Explicit
Sub ApplyToFirstFound()
Const wsNamesList As String = "A,B,C"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim wsNames() As String: wsNames = Split(wsNamesList, ",")
Dim wsName As String
Dim n As Long
For n = 0 To UBound(wsNames)
If WorksheetExists(wb, wsNames(n)) Then
wsName = wsNames(n)
Exit For
End If
Next n
' You could continue with...
If n > UBound(wsNames) Then
MsgBox "No worksheet exists.", vbCritical, "ApplyToFirstFound"
Exit Sub
End If
MsgBox "The first found worksheet is named '" & wsName & "'.", _
vbInformation, "ApplyToFirstFound"
' ... continue...
' ... or with a different code for each worksheet (I've used the same.).
Select Case wsName
Case "A"
MsgBox "Applying to '" & wsName & "'.", _
vbInformation, "ApplyToFirstFound"
Case "B"
MsgBox "Applying to '" & wsName & "'.", _
vbInformation, "ApplyToFirstFound"
Case "C"
MsgBox "Applying to '" & wsName & "'.", _
vbInformation, "ApplyToFirstFound"
Case Else
MsgBox "No worksheet exists.", vbCritical, "ApplyToFirstFound"
End Select
End Sub
Function WorksheetExists( _
ByVal wb As Workbook, _
ByVal WorksheetName As String) _
As Boolean
On Error GoTo ClearError
Dim ws As Worksheet: Set ws = wb.Worksheets(WorksheetName)
WorksheetExists = Not ws Is Nothing
Exit Function
ClearError:
Resume Next
End Function
I have a workbook with many sheets. I am webscraping with numbers, and then making each sheet have the number as the name. I want to display an error if the number has already been given to a sheet. I also want the user to be able to enter a new sheetname if so, but the program keeps popping up its own error message before I can do this.
The number is in cell D10 in the worksheet.
For Each Sheet In ThisWorkbook.Sheets
If Sheet.Name = Range("D10") Then
MsgBox ("ERROR: This Acct No has already been formulated")
NewName = InputBox("Please Rename:")
ActiveSheet.Name = NewName
ElseIf Sheet.Name <> Range("D10") Then
ActiveSheet.Name = Range("D10")
End If
Next Sheet
I expect my own message to pop up, but Excel just pops its own error message.
try this:
Dim MyDuplicate as boolean
MyDuplicate = False
For Each Sheet In ThisWorkbook.Sheets
If Sheet.Name = Range("D10") Then
MsgBox ("ERROR: This Acct No has already been formulated")
NewName = InputBox("Please Rename:")
ActiveSheet.Name = NewName
MyDuplicate = True
Exit for
End If
Next Sheet
If MyDuplicate = False then ActiveSheet.Name = Range("D10")
BTW, I do recommend you avoid using ActiveSheet and assign the sheet to a variable instead.
Option Explicit
Sub TestMe()
Dim wks As Worksheet
Worksheets.Add After:=ActiveSheet
For Each wks In ThisWorkbook.Worksheets
With wks
If .Name = .Range("D10") Then
MsgBox ("ERROR: This Acct No has already been formulated")
.Name = InputBox("Please Rename:")
ElseIf .Name <> .Range("D10") Then
If Trim(.Range("D10")) = "" Then
.Range("D10") = Replace(Replace(Now, ":", "_"), "/", "_")
Application.Wait Now + #12:00:02 AM#
End If
.Name = .Range("D10").Value
End If
End With
Next wks
End Sub
This is some idea how to do it, avoiding the Activate and Select, as per the How to avoid using Select in Excel VBA
(Ironically, I have left Worksheets.Add After:=ActiveSheet)
The part .Range("D10") = Replace(Replace(Now, ":", "_"), "/", "_") writes the current date and time, making sure it is always a unique one, by waiting 2 seconds on the next line - Application.Wait Now + #12:00:02 AM#
Rather than looping every sheet to check for duplicates, create a function that returns a boolean. This function will have an error if the sheet doesn't exist, and no error if the sheet does exist. We check for that error, and return True if sheet exists, False otherwise.
Option Explicit
Private Function SheetExists(wsName As String, Optional wb As Workbook = Nothing) As Boolean
Dim ws As Worksheet
On Error Resume Next
If wb Is Nothing Then
Set ws = Worksheets(wsName)
Else
Set ws = wb.Worksheets(wsName)
End If
SheetExists = (Err.Number = 0)
End Function
And then your code could be replaced with the following, which will keep calling on the InputBox as many times as necessary in order to prevent the user from inputting another invalid/duplicate entry. For this, I've combined the MsgBox and InputBox text, seems unnecessary to throw two prompts at the user when we can use the InputBox to both inform and ask for new input.
Dim ws as Worksheet
Dim newName as String
Set ws = ActiveSheet ' would be better to avoid this, but OK.
newName = Range("D10").Value
While SheetExists(newName, ws.Parent)
newName = InputBox("ERROR: This Acct No has already been formulated!" & vbCrLf & vbCrLf & _
newName & " already exists! Enter new name:")
Wend
ws.Name = newName
I am using the below code to rename worksheet.
Option Explicit
Sub RenWSs()
Dim ws As Worksheet
Dim shtName
Dim newName As String
Dim i As Integer
Dim RngStr As String
RngStr = Application.InputBox(prompt:="Select the Range for the new Sheet's name", Type:=2)
For Each ws In Worksheets
With ws
If Trim(.Range(RngStr)) <> "" Then
shtName = Split(Trim(.Range(RngStr)), " ")
newName = shtName(0)
On Error GoTo ws_name_error
.Name = .Range(RngStr)
GoTo done
repeat:
.Name = newName & i
GoTo done
ws_name_error:
i = i + 1
Resume repeat
End If
End With
On Error GoTo 0
done:
Next
End Sub
In this i am selecting the new name through Input Box and its working fine. Now what i want is, before calling the input box, the below process has to be done.
I have names in drop down list, each names in drop down list to be updated one by one in all worksheets like J16 is the cell.
Please help me
The code below will lopp through all ws sheets, and modifies the value of cell in "J16" to "Test 1" (just for testing purposes).
Option Explicit
Sub ModifyDropDownValue()
Dim ws As Worksheet
For Each ws In Worksheets
With ws
' modify the value in cell J16
.Range("J16").Value = "Test 1"
End With
Next ws
End Sub
I have done 2 separate prog till now.
One displays a message box before closing a workbook:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim answer As String
Dim question As String
question = "Display all the sheets which are Unprotected"
answer = MsgBox(question, vbYesNo)
If answer = vbNo Then
MsgBox "complete everything and then close"
Cancel = True
Exit Sub
Else
ThisWorkbook.Save
End If
End Sub
Another displays in a new sheet "Unprotected", list of all the unprotected sheets.
Sub UnprotectSheet()
Dim ws As Worksheet, a As Range
ActiveWorkbook.Worksheets.Add.Name = "Unprotected"
For Each ws In ActiveWorkbook.Worksheets
If ws.ProtectContents = False And ws.Name <> "Unprotected" Then
CNT = Sheets("Unprotected").Cells(Sheets("Unprotected").Rows.Count, "A").End(xlUp).Row
Sheets("Unprotected").Cells(CNT + 1, "A") = ws.Name
End If
Next
End Sub
I want a Message box to appear if I try to close the worksheet and if any sheet is unprotected, the message box displays the names of the unprotected sheets. I am facing problem in combining the above 2 codes.
I am not a VBA expert and I am trying it but unable to solve it.
Something like this can show you a list of the unprotected sheets. However, it's probably better to just use VBA to force their protection, rather than prompting the user to do it (unless they need to provide a password for protection status).
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim answer As String
Dim question As String
Dim unprotected as String
unprotected = GetUnprotectedSheets(ThisWorkbook)
If unprotected <> vbNullString Then
MsgBox "Please protected the following worksheets before closing" & vbCRLF & unprotected
Cancel = True
Exit Sub
Else
ThisWorkbook.Save
End If
End Sub
Function GetUnprotectedSheets(wb as Workbook)
'Custom function to return a string of sheet names
' which are unprotected
Dim ret as String
Dim ws as Worksheet
For each ws in wb.Worksheets
If Not ws.ProtectContents Then
ret = IIF(ret = "", ws.Name, ret & vbCRLF & ws.Name)
End If
Next
GetUnprotectedSheets = ret
End Function
You can call a procedure like this to ensure all sheets are protected:
Sub ProtectAllSheets(wb as Workbook)
Dim ws as Worksheet
For each ws in wb.Worksheets
If Not ws.ProtectContents Then ws.Protect
Next
End Sub
Just add a counter to your second script:
Sub UnprotectSheet()
Dim ws As Worksheet, a As Range
Dim iCounter As Integer, strMessage As String 'Adding a counter variable & string
'ActiveWorkbook.Worksheets.Add.Name = "Unprotected"
iCounter = 0 'Initialize it
strMessage = "" 'Initialize empty string for the message box
For Each ws In ActiveWorkbook.Worksheets
If ws.ProtectContents = False Then
iCounter = iCounter + 1 'Keeping track of any unprotected sheet
' CNT = Sheets("Unprotected").Cells(Sheets("Unprotected").Rows.Count, "A").End(xlUp).Row
' Sheets("Unprotected").Cells(CNT + 1, "A") = ws.Name
strMessage = strMessage & ws.Name & " "
End If
Next
' Here you can do your msgbox or any other action if unprotected sheet detected
If iCounter > 0 Then
MsgBox ("These sheets are unprotected: " & strMessage)
End If
End Sub
EDIT:
To enclose that within a button click: add an activeX button to your form, then:
Private Sub CommandButton1_Click()
'E.g. make the sub a commmandbutton_click() event
End Sub
Actually, when you add the button to your form, if you right-click on it you have the option "View code" - this will create an associated Commandbutton_click like I showed above.