VBA Rename a TAB to the First 12 Chracters of a Cell String

[SamBo1234]

Hi ya'll and good morning,

First problem of the day,

I need some VBA code to help me rename the TAB (Of the Worksheet) to a Cell....

However i only want to rename the Sheet Name to the first 12 chracters of the Cell containing the string...

So for example in A1 it has Missing_Data_&1234_*Hello_%goodbye

Because you cant use special chracters on the names of tabs i only want to return the first 12 chracters so it would basically be 'Missing_Data'

 

[itlsbu]

SamBo,

would this help

Sub macro1()

Dim name1 As String

Range("a2").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],12)"
name1 = range("a2")

ActiveSheet.Name = name1
End Sub

cheers steven

 

[SamBo1234]

Hi there,

Im getting the following error,


Application-defined or object-defined error

 

[Darren Bartrup]

How about this way:

To run the two procedures:

Public Sub Demo()

    Rename_Sheet ThisWorkbook.Worksheets(1)
    Rename_Sheet_Alternate ThisWorkbook.Worksheets(1)

End Sub

Replace any illegal characters in worksheet name with an underscore:

Public Sub Rename_Sheet(wrksht As Worksheet)

    Dim ReplaceString(1 To 7)   As String
    Dim NewSheetName            As String
    Dim iCntr                   As Integer

    ReplaceString(1) = "\"
    ReplaceString(2) = "/"
    ReplaceString(3) = "?"
    ReplaceString(4) = "*"
    ReplaceString(5) = "["
    ReplaceString(6) = "]"
    ReplaceString(7) = "'"
'    ReplaceString(8) = "&"
'    ReplaceString(9) = "%"
    
    NewSheetName = wrksht.Cells(1, 1)
    For iCntr = LBound(ReplaceString) To UBound(ReplaceString)
        NewSheetName = Replace(NewSheetName, ReplaceString(iCntr), "_")
    Next iCntr

    wrksht.Name = Trim(NewSheetName)

End Sub

Use first 12 characters of string in cell A1:

Public Sub Rename_Sheet_Alternate(wrksht As Worksheet)

    wrksht.Name = Left(wrksht.Cells(1, 1), 12)

End Sub

Edit: My bad, % and & aren't illegal so edited them out.

 

[Richard Schollar]

Or simply:

Sheets("Sheet1").Name = Left$(Sheets("Sheet1").Range("A1").Value,12)

Richard

 

[SamBo1234]

Hi and thanks for your replies guys,

Im trying to get it to work with the following code...

Option Explicit

Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer
    Dim ShCnt As Integer
    Dim i As Integer, strFile As String
    
    
         
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
      MultiSelect:=True, Title:="Files to Merge")

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "No Files were selected"
        GoTo ExitHandler
    End If

    x = 1
    strFile = Right(FilesToOpen(1), Len(FilesToOpen(1)) - InStrRev(FilesToOpen(1), "\"))
    While x <= UBound(FilesToOpen)
        Workbooks.Open Filename:=FilesToOpen(x)
        If x = 1 Then
             For i = 1 To Workbooks(strFile).Sheets.Count
                    Rows("1:2").Select
                    Selection.EntireRow.Insert
                    Workbooks(strFile).Sheets(i).Range("A1") = Dir(FilesToOpen(x))
                    Workbooks(strFile).Sheets(i).Range("A1").Font.Bold = True
                    Range("A2:A" & Rows.Count).Columns.AutoFit
                    Columns("B:H").AutoFit
                    Sheets("Sheet1").Name = Left$(Sheets("Sheet1").Range("A1").Value, 12)
                    Next i
         End If
        With Workbooks(strFile)
                ShCnt = .Sheets.Count
                Sheets().Move After:=.Sheets(ShCnt)
                For i = ShCnt + 1 To .Sheets.Count
                Rows("1:2").Select
                Selection.EntireRow.Insert
                   .Sheets(i).Range("A1") = Dir(FilesToOpen(x))
                   .Sheets(i).Range("A1").Font.Bold = True
                   Range("A2:A" & Rows.Count).Columns.AutoFit
                    Columns("B:H").AutoFit
                
                   Next i
        End With
        x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

Richard, i tryed to include your line of code here,

  For i = 1 To Workbooks(strFile).Sheets.Count
                    Rows("1:2").Select
                    Selection.EntireRow.Insert
                    Workbooks(strFile).Sheets(i).Range("A1") = Dir(FilesToOpen(x))
                    Workbooks(strFile).Sheets(i).Range("A1").Font.Bold = True
                    Range("A2:A" & Rows.Count).Columns.AutoFit
                    Columns("B:H").AutoFit
                    Sheets("Sheet1").Name = Left$(Sheets("Sheet1").Range("A1").Value, 12)
                    Next i

But im getting the following error:


Subscript out of range


Havent tryed the other alternatives... ill give it a whirl.

 

[Richard Schollar]

Subscript out of range error suggests you don't have a sheet named Sheet1. You're using i to refer to the sheet in the code, so use this again:

Sheets(i).Name = Left$(Sheets(i).Range("A1").Value, 12)

Make sure that it is the value in A1 that you want to be picking up.

Richard

 

[SamBo1234]

Always a pleasure Richard,

Many thanks once again!