I have checked a lot of different solutions here on stackoverflow, but none of them worked for me.
When I insert a value like "1" everything works, but When I try to insert my formula I always get a runtime error. Does anyone have an explanation? Would be very thankful for any help!
Sub test()
Dim cell As Excel.Range
Dim wsWithSheetNames As Excel.Worksheet
Dim wbToAddSheetsTo As Excel.Workbook
Set wsWithSheetNames = ActiveSheet
Set wbToAddSheetsTo = ActiveWorkbook
For wsname = 1 To 254
For Each cell In wsWithSheetNames.Range("A" & wsname)
With wbToAddSheetsTo
.Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = cell.Value
wsname2 = cell.Value
If Err.Number = 1004 Then
Debug.Print cell.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next cell
Worksheets("Sheet1").Range("B1", "B1735").Copy
Worksheets(wsname2).Range("A2")
(HERE IS THE PROBLEM!)Worksheets(wsname2).Range("B2:AGR1736").FormulaLocal =
"=IFERROR(VLOOKUP($A2,OFFSET([final.xlsb]" & CHr(34) & wsname2 & Chr(34) & "!$A$1:$D$2000,0,
(COLUMN(A2)*4-4)),4,0),"")"
Next wsname
End Sub
EDIT: changed the line to:
Worksheets(wsname2).Range("B2:AGR1736").FormulaLocal =
"=IFERROR(VLOOKUP($A2,OFFSET([final.xlsb]" & wsname2 & "!$A$1:$D$2000,0,
(COLUMN(A2)*4-4)),4,0)," & Chr(34) & Chr(34) & ")"
If I dont write the "=" the code works just fine, why is it not working with the "="?
I think you need to declare wsname and wsname 2, so the full code would be like this:
Sub test()
Dim cell As Excel.Range
Dim wsWithSheetNames As Excel.Worksheet
Dim wbToAddSheetsTo As Excel.Workbook
Dim wsname As Integer
Dim wsname2 As String
Set wsWithSheetNames = ActiveSheet
Set wbToAddSheetsTo = ActiveWorkbook
For wsname = 1 To 254
For Each cell In wsWithSheetNames.Range("A" & wsname)
With wbToAddSheetsTo
.Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = cell.Value
wsname2 = cell.Value
If Err.Number = 1004 Then
Debug.Print cell.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next cell
Worksheets("Sheet1").Range("B1", "B1735").Copy Worksheets(wsname2).Range("A2")
'Worksheets(wsname2).Range("B2:AGR1736").FormulaLocal =
'"=IFERROR(VLOOKUP($A2,OFFSET([final.xlsb]" & CHr(34) & wsname2 & Chr(34) & "!$A$1:$D$2000,0,
'(COLUMN(A2)*4-4)),4,0),"")"
Worksheets(wsname2).Range("B2:AGR1736") = "=IFERROR(VLOOKUP($A2,OFFSET([final.xlsb]" & wsname2 & "!$A$1:$D$2000,0," & "(COLUMN(A2)*4-4)),4,0)," & Chr(34) & Chr(34) & ")"
Next wsname
End Sub
Hope this help.
Related
I am currently working on a VBA project. I have a workbook with multiple tabs from different workbooks. The names of all the tabs are the same, however since they come from different files, I would like to name them based on the filenames they are extracted from. The filenames are present in the cell EC1 of every tab. I would like to name all the sheets in the workbook based on the value present in cell EC1 of each individual sheet.
I have the following code:
Sub RenameSheet()
Dim rs As Worksheet
For Each rs In Sheets
rs.Name = rs.Range("EC1")
Next rs
End Sub
I have been getting a 1004 error from the above code.
I tried this code too:
Sub RenameSheet()
Dim xWs As Worksheet
Dim xRngAddress As String
Dim xName As String
Dim xSSh As Worksheet
Dim xInt As Integer
xRngAddress = Application.ActiveCell.Address
On Error Resume Next
Application.ScreenUpdating = False
For Each xWs In Application.ActiveWorkbook.Sheets
xName = xWs.Range(xRngAddress).Value
If xName <> "" Then
xInt = 0
Set xSSh = Nothing
Set xSSh = Worksheets(xName)
While Not (xSSh Is Nothing)
Set xSSh = Nothing
Set xSSh = Worksheets(xName & "(" & xInt & ")")
xInt = xInt + 1
Wend
If xInt = 0 Then
xWs.Name = xName
Else
If xWs.Name <> xName Then
xWs.Name = xName & "(" & xInt & ")"
End If
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Some sheets do get renamed, however some do not. I have checked for duplicate sheet names, and there are none. I have also checked if the filename is in the correct range (cell), and it is present.
There might be problems with the value if it contains some special characters. The excel sheets can have some restrictions for their names, if thats the problem, my code could be the solution.
It cuts the string to a maximum length of 31 chars and deletes all the special chars which are not allowed in names.
Sub RenameSheet()
Dim rs As Worksheet
For Each rs In Sheets
sheetName = without_special_chars(rs.Range("EC1").Value)
If Len(sheetName) > 31 Then
sheetName = Left(sheetName, 31)
End If
rs.Name = sheetName
Next rs
End Sub
Function without_special_chars(text As String) As String
Dim i As Integer
Const special_chars As String = "-.,:;#+ß'*?=)(/&%$§!~\}][{"
For i = 1 To Len(special_chars)
text = Replace(text, Mid(special_chars, i, 1), "")
Next i
without_special_chars = text
End Function
Rename Multiple Worksheets
A Quick Fix
Your first code should have been something like this:
Sub renameWorksheetsQF()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Name = ws.Range("EC1").Value
Next ws
End Sub
Note the not so subtile differences.
In Depth
Option Explicit
Sub renameWorksheets()
On Error GoTo clearError
Const cAddress As String = "A1" ' "EC1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet
Dim cel As Range
Dim oName As String
Dim nName As String
For Each ws In wb.Worksheets
oName = ws.Name
Set cel = ws.Range(cAddress)
If IsError(cel) Then
Debug.Print "Cell '" & cAddress & "' in worksheet '" _
& oName & "' contains the error value '" & cel.Text & "'."
Else
If IsEmpty(cel) Then
Debug.Print "Cell '" & cAddress & "' in worksheet '" _
& oName & "' is an empty cell."
Else
nName = CStr(cel.Value)
On Error GoTo RenameError
If oName <> nName Then
ws.Name = nName
Else
Debug.Print "Worksheet '" & oName _
& "' had previously been renamed."
End If
On Error GoTo clearError
End If
End If
Next ws
ProcExit:
Exit Sub
RenameError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Debug.Print " Could not rename '" & oName & "' to '" & nName & "'."
Resume Next
clearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Debug.Print " Unexpected error."
Resume ProcExit
End Sub
I have written this code and it has worked until now.
I have put two AutoFilter to pull certain rows. How do I amend the code to copy and paste visible rows?
I tried
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy'
which copies the cells but then I get an error. Object required
Sub LoopThrough()
Dim MyFile As String, Str As String, MyDir As String
Dim sh As Worksheet, MasterRange As Range, TempWB As Workbook, TempSH As Worksheet, TempRng As Range
Dim NewMasterLine As Long
On Error GoTo ErrorHandler
Set sh = ThisWorkbook.Worksheets("Sheet2")
MyDir = "C:\Users\eldri\OneDrive\Desktop\New folder (2)\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While MyFile <> ""
'opens excel
Set TempWB = Workbooks.Open(FileName:=MyFile, UpdateLinks:=False,
Password:=CalcPassword(MyFile))
Set TempSH = TempWB.Worksheets(1)
Columns(1).Insert
Range("c2").Copy Range("A4:A10000")
Worksheets("Data").Range("A4").AutoFilter Field:=3, Criteria1:="AMS"
Worksheets("Data").Range("A4").AutoFilter Field:=4, Criteria1:="XNE"
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row)
NewMasterLine = sh.Range("B" & sh.Rows.Count).End(xlUp).Row
If NewMasterLine > 1 Then NewMasterLine = NewMasterLine + 1
Set MasterRange = sh.Range("A" & NewMasterLine & ":CW" & (NewMasterLine + TempRng.Rows.Count))
MasterRange.Value = TempRng.Value
'Debug.Print "Imported File: " & MyFile & ", Imported Range: " & TempRng.Address & ", Destination Range: " & MasterRange.Address
TempWB.Close savechanges:=False
MyFile = Dir()
Loop
MsgBox ("Done")
ErrorHandler:
If Err.Number <> 0 Then MsgBox "An error occurred." & vbNewLine & vbNewLine & "Last file that was attempted to be opened: " & MyFile & vbNewLine & vbNewLine & Err.Description
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
You cannot use Set and .Copy in one line.
First you need to set your range of visible cells:
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
Then you need to test if there were visible cells found and if so you can copy them:
If Not TempRng Is Nothing Then
TempRng.Copy
'all code that relies on the copied range `TempRng` needs to go here
Else
MsgBox "No visible cells found!"
End If
I rewrote the code with the advice from #PEH and it worked - Please find the new code below.
Sub LoopThrough()
Dim MyFile As String, Str As String, MyDir As String
Dim sh As Worksheet, MasterRange As Range, TempWB As Workbook, TempSH As Worksheet, TempRng As Range, TempRow As Range
Dim NewMasterLine As Long
On Error GoTo ErrorHandler
Set sh = ThisWorkbook.Worksheets("Sheet2")
' Change address to suite
MyDir = "C:\Users\eldri\OneDrive\Desktop\W220Q1\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
' The following lines will put excel in a state similar to "frozen" mode. This will increase the code performance, as CPU will solely focus on performing
' the operations required by the code and not on showing the changes happening on excel
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Here starts the loop related to the files in folder
Do While MyFile <> ""
'TempWB is a Worksheet object - will be the importing worksheet. TempRng is the used range in sheet 1 of the workbook
Set TempWB = Workbooks.Open(FileName:=MyFile, UpdateLinks:=False, Password:=CalcPassword(MyFile))
Columns(1).Insert
Range("c2").Copy Range("A4:A10000")
Set TempSH = TempWB.Worksheets(1)
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("A" & TempSH.Rows.Count).End(xlUp).Row)
'NewMasterLine is the last used row (+1) of the Master Workbook (It is basically where the new rows wiill start to be imported)
NewMasterLine = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
If NewMasterLine > 1 Then NewMasterLine = NewMasterLine + 1
'This will loop through all the rows of the range to be imported, checking the first column.
' If the value in the second column is work-xne-ams, will import the single row in the master worklbook
For Each TempRow In TempRng.Rows
If TempRow.Cells(1, 3).Value = "AMS" And TempRow.Cells(1, 4).Value = "XNE" Or TempRow.Row < 4 Then
Set MasterRange = sh.Range("A" & NewMasterLine & ":CW" & NewMasterLine)
MasterRange.Value = TempRow.Value
NewMasterLine = NewMasterLine + 1
End If
Next
TempWB.Close savechanges:=False
MyFile = Dir()
Loop
MsgBox ("Done")
ErrorHandler:
If Err.Number <> 0 Then MsgBox "An error occurred." & vbNewLine & vbNewLine & "Last file that was attempted to be opened: " & MyFile & vbNewLine & vbNewLine & Err.Description
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function CalcPassword(FileName As String) As String
CalcPassword = ""
On Error Resume Next
Dim TheFile As String: TheFile = Split(Split(FileName, "\")(UBound(Split(FileName, "\"))), ".")(0)
Dim PWD As Range: Set PWD = ThisWorkbook.Worksheets("PWD").ListObjects("PWD").DataBodyRange
CalcPassword = WorksheetFunction.VLookup(TheFile, PWD, 5, False)
End Function
I was using the script which I found here : https://excelribbon.tips.net/T008349_Counting_All_Characters.html
It is working as expected however when there are some other objects like pictures, the script returns me the error 438"Object Doesn't Support This Property or Method".
When I deleted the pictures the script was working well again.
Is there an option to put in the script something like "ignore pictures"? Or is there any better type of script to achieve this? I am not good at all at VBA, all help will be much appreciated.
Here's a simplified approach that may work out a bit better. I think being explicit which Shape Types you want to count is going to be a cleaner way of going about this.
Option Explicit
Private Function GetCharacterCount() As Long
Dim wks As Worksheet
Dim rng As Range
Dim cell As Range
Dim shp As Shape
For Each wks In ThisWorkbook.Worksheets
For Each shp In wks.Shapes
'I'd only add the controls I care about here, take a look at the Shape Type options
If shp.Type = msoTextBox Then GetCharacterCount = GetCharacterCount + shp.TextFrame.Characters.Count
Next
On Error Resume Next
Set rng = Union(wks.UsedRange.SpecialCells(xlCellTypeConstants), wks.UsedRange.SpecialCells(xlCellTypeFormulas))
On Error GoTo 0
If not rng Is Nothing Then
For Each cell In rng
GetCharacterCount = GetCharacterCount + Len(cell.Value)
Next
end if
Next
End Function
Sub CountCharacters()
Debug.Print GetCharacterCount()
End Sub
It looks like you can add an if-check like the one here (VBA Code to exclude images png and gif when saving attachments for "PNG" and "GIF".).
You just have to change the if-check to check for the picture type you're using "JPG" or "JPEG"? Simply match the extension to the if-check by replacing "PNG" or "GIF" with your extension in CAPS.
Add the if-check right above where the error is occurring or better yet, add it above the scope of where the error is occurring.
I took the script from your link and modified it. Now it works.
It's far from perfect (there're some cases where it can still crash), but now it supports handling Shapes with no .TextFrame property:
Sub CountCharacters()
Dim wks As Worksheet
Dim rng As Range
Dim rCell As Range
Dim shp As Shape
Dim bPossibleError As Boolean
Dim bSkipMe As Boolean
Dim lTotal As Long
Dim lTotal2 As Long
Dim lConstants As Long
Dim lFormulas As Long
Dim lFormulaValues As Long
Dim lTxtBox As Long
Dim sMsg As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
lTotal = 0
lTotal2 = 0
lConstants = 0
lFormulas = 0
lFormulaValues = 0
lTxtBox = 0
bPossibleError = False
bSkipMe = False
sMsg = ""
For Each wks In ActiveWorkbook.Worksheets
' Count characters in text boxes
For Each shp In wks.Shapes
If TypeName(shp) <> "GroupObject" Then
On Error GoTo nextShape
lTxtBox = lTxtBox + shp.TextFrame.Characters.Count
End If
nextShape:
Next shp
On Error GoTo ErrHandler
' Count characters in cells containing constants
bPossibleError = True
Set rng = wks.UsedRange.SpecialCells(xlCellTypeConstants)
If bSkipMe Then
bSkipMe = False
Else
For Each rCell In rng
lConstants = lConstants + Len(rCell.Value)
Next rCell
End If
' Count characters in cells containing formulas
bPossibleError = True
Set rng = wks.UsedRange.SpecialCells(xlCellTypeFormulas)
If bSkipMe Then
bSkipMe = False
Else
For Each rCell In rng
lFormulaValues = lFormulaValues + Len(rCell.Value)
lFormulas = lFormulas + Len(rCell.Formula)
Next rCell
End If
Next wks
sMsg = Format(lTxtBox, "#,##0") & _
" Characters in text boxes" & vbCrLf
sMsg = sMsg & Format(lConstants, "#,##0") & _
" Characters in constants" & vbCrLf & vbCrLf
lTotal = lTxtBox + lConstants
sMsg = sMsg & Format(lTotal, "#,##0") & _
" Total characters (as constants)" & vbCrLf & vbCrLf
sMsg = sMsg & Format(lFormulaValues, "#,##0") & _
" Characters in formulas (as values)" & vbCrLf
sMsg = sMsg & Format(lFormulas, "#,##0") & _
" Characters in formulas (as formulas)" & vbCrLf & vbCrLf
lTotal2 = lTotal + lFormulas
lTotal = lTotal + lFormulaValues
sMsg = sMsg & Format(lTotal, "#,##0") & _
" Total characters (with formulas as values)" & vbCrLf
sMsg = sMsg & Format(lTotal2, "#,##0") & _
" Total characters (with formulas as formulas)"
MsgBox Prompt:=sMsg, Title:="Character count"
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
If bPossibleError And Err.Number = 1004 Then
bPossibleError = False
bSkipMe = True
Resume Next
Else
MsgBox Err.Number & ": " & Err.Description
Resume ExitHandler
End If
End Sub
You could try:
Option Explicit
Sub test()
Dim NoOfChar As Long
Dim rng As Range, cell As Range
NoOfChar = 0
For Each cell In ThisWorkbook.Worksheets("Sheet1").UsedRange '<- Loop all cell in sheet1 used range
NoOfChar = NoOfChar + Len(cell.Value) '<- Add cell len to NoOfChar
Next cell
Debug.Print NoOfChar
End Sub
I have a problem with a VBA-based hyperlink in Excel 2016. I want to add a "Navigation" sheet in front of all other sheets but I have an issue with "=HYPERLINK". My code is the following:
Dim wbBook As workbook
Dim wsActive As Worksheet
Dim wsSheet As Worksheet
Dim lnRow As Long
Dim lnPages As Long
Dim lnCount As Long
Dim temp As Variant
Set wbBook = ActiveWorkbook
wbBook.Sheets.Add(Before:=Worksheets(1)).Name = "Navigation"
Set wsActive = wbBook.ActiveSheet
With wsActive
.Name = "Navigation"
With .Range("A1:A1")
.Value = VBA.Array("Mitarbeiter")
.Font.Bold = True
End With
End With
lnRow = 2
lnCount = 1
For Each wsSheet In wbBook.Worksheets
If wsSheet.Name <> wsActive.Name Then
wsSheet.Activate
With wsActive
Worksheets("Navigation").Cells(lnRow, 1).Formula = _
"=HYPERLINK(" & Chr(34) & "#" & "'" & wsSheet.Name & "'" & "!A" & lnRow & Chr(34) & ";" & Chr(34) & wsSheet.Name & Chr(34) & ")"
End With
lnRow = lnRow + 1
lnCount = lnCount + 1
End If
Next wsSheet
The problem I have is that when I add an "=" in front of HYPERLINK, the error "Anwendungs- oder objektorientierter Fehler" (application or object oriented error) pops up. If I run the macro without the "=", the program works but I manually have to add the equation sign in the navigation sheet.
Cheers in advance!
Since you are already using VBA, why not the VBA capability of Adding Hyperlinks (with .Hyperlinks.Add).
You can read about it more on MSDN
I reduced a the use of ActiveSheet, and Activate.
Code
Option Explicit
Sub TestHyperlink()
Dim wbBook As Workbook
Dim wsActive As Worksheet
Dim wsSheet As Worksheet
Dim lnRow As Long
Dim lnPages As Long
Dim lnCount As Long
Dim temp As Variant
Set wbBook = ActiveWorkbook
Set wsActive = wbBook.Sheets.Add(Before:=Worksheets(1))
With wsActive
.Name = "Navigation"
With .Range("A1:A1")
.Value = VBA.Array("Mitarbeiter")
.Font.Bold = True
End With
End With
lnRow = 2
lnCount = 1
For Each wsSheet In wbBook.Worksheets
If wsSheet.Name <> wsActive.Name Then
With wsSheet
.Hyperlinks.Add Anchor:=Worksheets("Navigation").Range("A" & lnRow), _
Address:="", SubAddress:="'" & .Name & "'!" & .Range("A" & lnRow).Address, _
TextToDisplay:="#" & .Name
End With
lnRow = lnRow + 1
lnCount = lnCount + 1
End If
Next wsSheet
End Sub
Try using a comma to separate the parameters of the formula instead of a semicolon. I think forcing formulae into cells like this ignores localisation.
With wsActive
Worksheets("Navigation").Cells(lnRow, 1).Formula = _
"=HYPERLINK(" & Chr(34) & "#" & "'" & wsSheet.Name & "'" & "!A" & lnRow & Chr(34) & "," & Chr(34) & wsSheet.Name & Chr(34) & ")"
End With
The code below is what i use to rename a bunch of sheets within a workbook. it works perfectly. It renames the sheet based off of a cell in that sheet. but now i have two sheets trying to use the same name. So i want to keep the same code but add a loop so if that happens, it will add a "2" to the second sheet. Ie cell contains "John Doe". Sheet will rename to "John Doe" and the next sheet that tries to use it will rename "John Doe 2"
Thank you
Sub RenameLaborLog()
Dim rs As Worksheet
For Each rs In Sheets
rs.Name = Split(rs.Range("H4").Value, " ")(1) & ", " & Left(Split(rs.Range("H4").Value)(0), 1) & "."
Next rs
End Sub
just to show another way you can reach your goal
Sub RenameLaborLog()
Dim rs As Worksheet, i As Long, str As String
On Error Resume Next
For Each rs In Sheets
str = Split(rs.Range("H4").Value, " ")(1) & ", " & Left(Split(rs.Range("H4").Value)(0), 1) & "."
rs.Name = str
i = 1
While Err.Number <> 0 And i < 20
Err.Clear: i = i + 1
rs.Name = str & i
Wend
If Err.Number <> 0 Then MsgBox "Error: " & rs.Name & " cant be set to any " & str: Exit Sub
Next rs
End Sub
it tries to set the name (and if that is not working it sets the name & 2 - 19 (if that doesnt work, it pops up a message box and exits the sub)
Use a controlled error to adjust the string containing the worksheet name until it find something it can use.
Sub RenameLaborLog()
Dim rs As Worksheet, snam As String, idupe As Long
On Error GoTo bm_Dupe_WS_Name
For Each rs In Sheets
idupe = 1
snam = Split(rs.Range("H4").Value, " ")(1) & ", " & _
Left(Split(rs.Range("H4").Value)(0), 1) & "."
rs.Name = snam
Next rs
bm_Dupe_WS_Name:
If idupe > 8 Then
Debug.Print Err.Number & ": " & snam & " - " & Err.Description
Exit Sub
ElseIf Right(snam, 1) = CStr(idupe) Then
snam = Trim(Left(snam, Len(snam) - 1))
End If
idupe = idupe + 1
snam = snam & Chr(32) & idupe
Resume
End Sub
I have it set yo attempt a numerical suffix up to 9. It it reaches that, it reports the error and exits the sub. I would not recommend running this without an escape clause. If nothing else, you may run into an illegal character when parsing the string for the worksheet name.
Based on the link #Scott Craner provided in his comment, I am providing another solution that I believe is a bit more functional and cleaner and easier to read.
Sub RenameLaborLog()
Dim rs As Worksheet, sName As String
For Each rs In Sheets
sName = Split(rs.Range("H4").Value, " ")(1) & ", " & Left(Split(rs.Range("H4").Value)(0), 1) & "."
i = 1
Do
If Not WorksheetExist(sName) Then
rs.Name = sName
Exit Do
Else: sName = sName & "_" & i + 1
End If
Loop
Next rs
End Sub
Function WorksheetExist(sName As String, Optional wb As Workbook) As Boolean
Dim wbCheck As Workbook, ws As Worksheet
If wb Is Nothing Then Set wbCheck = ThisWorkbook Else: Set wbCheck = wb
WorksheetExist = False
For Each ws In wbCheck.Worksheets
If ws.Name = sName Then
WorksheetExist = True
Exit For
End If
Next
End Function
Jeeped beat me to it, but here is another possible adjustment you could make:
Sub RenameLaborLog()
Dim rs As Worksheet, wsName As String, wsCheck As Worksheet, i As Integer
For Each rs In Sheets
' Get the sheet name
wsName = Split(rs.Range("H4").Value, " ")(1) & ", " & Left(Split(rs.Range("H4").Value)(0), 1) & "."
' Check if it exists
Set wsCheck = Nothing: On Error Resume Next: Set wsCheck = wsName: On Error GoTo 0
' Check if multiples already exist
While Not wsCheck Is Nothing
' If even one exits, "i" will be iterated
i = i + 1
Set wsCheck = Nothing: On Error Resume Next: Set wsCheck = wsName & "_" & i: On Error GoTo 0
Wend
' If at least one name already existed, name it with the current iteration.
If Not i = 0 Then wsName = wsName & "_" & i
rs.Name = wsName
Next rs
Set rs = Nothing: Set wsCheck = Nothing
End Sub