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