Solved: Rename worksheets based cell value

[satish gubbi]

Hi

I need a macro code to rename all sheets in a workbook based on cell value

defined cell value has to be name of sheets/tab

Kindly help

[Bob Phillips]

For Each sh In Activeworkbook.Worksheets

sh.Name = sh.Range("A1").Value2
Next sh

[satish gubbi]

Thanks for the code, if the cell has many words, it should pick first word and rename the tab, if word is similar in the next tab it should add 1 at the end of the word

I am not technical guy, request you to provide full code

attached is file that I am working on, tabs has to be renamed as per cell "I2", if it has many words, it should pick first word only

Kindly help me in this

[Bob Phillips]

If you change the A1 in my code to I2 it works just fine.

You say you are not technical, but you are asking many questions. Have they given the job to the right person?

[wakdafak]

try this, it may help :)

Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim rng2 As Range
Dim colCount As Integer 'Column count in tables in the worksheets
Dim lookFor As Range
Dim col As Integer
Dim found As Variant
Dim acct As String
Dim wrk2 As Workbook
Dim sht2 As Worksheet
Dim sheetnum As Integer
Workbooks("AirBusOnline.xls").Worksheets("Account_Number").Select
lMaxSht = Sheets.Count
For shtno = 2 To lMaxSht

lMaxSupp = Cells(Rows.Count, 1).End(xlUp).Row

For suppno = 1 To lMaxSupp
acct = Workbooks("AirBusOnline.xls").Worksheets("Account_Number").Range("A" & suppno).Value
invno = Worksheets(shtno).Range("A2").Value

Workbooks("AirBusOnline.xls").Worksheets("Account_Number").Select

If acct = Worksheets(shtno).Range("D2").Value Then

Set wrk = ActiveWorkbook 'Working in active workbook

For Each sht In wrk.Worksheets
If sht.Name = acct & "_" & invno Then
MsgBox "There is a worksheet called as 'All File'." & vbCrLf & _
"Please remove or rename this worksheet since 'All File' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht

'We don't want screen updating
Application.ScreenUpdating = False

'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = acct & "_" & invno
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(shtno)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
'Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
'Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit

'Screen updating should be activated
Application.ScreenUpdating = True

End If
Next
Next
End Sub

[mancubus]

@wakdafak:
the code you posted is from:
http://www.vbaexpress.com/kb/getarticle.php?kb_id=151

so we should provide a link to the original post (or web site) to respect the efforts of the programmer / helper.


and since it's about consolidating all worksheets' data in a single worksheet, does not provide a solution to the request, which is, renaming worksheets based on cell value...

[mancubus]

not an elegant one but try this code with a copy of your file.


Sub RenWSs()
'http://vbaexpress.com/forum/showthread.php?t=40485

Dim ws As Worksheet
Dim shtName
Dim newName As String
Dim i As Integer

For Each ws In Worksheets
With ws
If Trim(.Range("I2")) <> "" Then
shtName = Split(Trim(.Range("I2")), " ")
newName = shtName(0)
On Error GoTo ws_name_error
.Name = newName
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

[satish gubbi]

Hi Mancubus,

This code worked as intended, thank you very much for your help in this regard.

[mancubus]

you're wellcome.

[MehtaKS]

worked brilliantly in my variable month change workbook:bow: :bow: :bow: