Sub RenameSheetsBasedOnSheet1()Dim ws As Worksheet
Dim sheet1 As Worksheet
Dim i AsLong, lastRow AsLongDim newName AsStringDim nameExists AsBoolean' Set the sheet1 worksheet (assuming it's named "Sheet1") Set sheet1 = ThisWorkbook.Sheets("Sheet1")' Find the last row with data in column A of Sheet1
lastRow = sheet1.Cells(sheet1.Rows.Count,1).End(xlUp).Row
' Loop through all sheets except Sheet1 For Each ws In ThisWorkbook.Sheets
If ws.Name<> sheet1.NameThen' Get the new name from Sheet1's A column
i = i +1If i <= lastRow Then
newName = sheet1.Cells(i,1).Value
' Check if the new name is valid and not already used
nameExists =FalseFor Each wks In ThisWorkbook.Sheets
If wks.Name= newName And wks.Name<> ws.NameThen
nameExists =TrueExitForEndIfNext wks
If newName <>""AndNot nameExists Then' Rename the sheet On ErrorResumeNext' In case of any error (e.g., invalid sheet name)
ws.Name= newName
If Err.Number <>0Then
MsgBox "Error renaming sheet to "& newName &": "& Err.Description, vbCritical
Err.ClearEndIfOn ErrorGoTo0' Reset error handling ElseIf newName =""Then
MsgBox "Empty name found in Sheet1 A"& i &". Skipping this rename.", vbExclamation
Else
MsgBox "Name """& newName &""" already exists. Skipping this rename.", vbExclamation
EndIfEndIfElseExitFor' No more names to assign EndIfEndIfNext ws
MsgBox "Sheets have been renamed based on Sheet1 A column where possible.", vbInformation
EndSub