i need to rename all my sheets dynamically based on a range of cell values.
This is my VBA codes, it keeps giving me a 'Runtime Error '1004 whenever i run it.
Sub RenameSheets()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Config").Range("A5")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Sheets("Sheet1").Activate
For Each MyCell In MyRange
ActiveSheet.Name = MyCell.Value 'Error here. it works fine if i rename MyCell.Value to "AnyRandomValue"
Worksheets(ActiveSheet.Index + 1).Select
Next MyCell
End Sub
I cant get my head around it. Why is it giving an error at MyCell.Value? Please help!
The problem I think is activating the sheets your working on by .Select method.
Avoid using select as much as possible. Check out the link.
Your code can be rewritten like below:
Sub RenameSheets()
Dim MyNames As Variant
MyRange As Range, ws As Worksheet
Dim i As Long
With Sheets("Config")
Set MyRange = .Range("A5", .Range("A" & _
.Rows.Count).End(xlUp).Address)
'~~> pass names to array
MyNames = Application.Transpose(MyRange)
i = Lbound(MyNames)
End With
'~~> iterate sheets instead
For Each ws In Worksheets
If ws.Name <> "Config" Then
ws.Name = MyNames(i) '~~> retrieve from array
i = i + 1
End If
Next ws
End Sub
Is this what you're trying?
Related
I have a column with 7000+ names. I want to make each name's length not excess to 5. Here is what I have tried which doesn't work
Sub del()
Dim myCell
Set myCell = ActiveCell
Dim count As Integer
count = Len(ActiveCell)
While count > 5
myCell = Left(myCell, Len(myCell) - 1)
myCell.Offset(1, 0).Select
Set myCell = ActiveCell
Wend
End Sub
No need for VBA. You can use a formula, =Left(A1,5), to get the first 5 characters of the cell. Simply autofill the formula down.
If you still want VBA then also you do not need to loop. See this example. For explanation see Convert an entire range to uppercase without looping through all the cells
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Dim rng As Range
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:A" & lRow)
rng = Evaluate("index(left(" & rng.Address(External:=True) & ",5),)")
End With
End Sub
In the above code I am assuming that the data is in column A in Sheet1. Change as applicable.
In Action
I am trying to select all the data in a column and make it proper case.
This is what I'm starting with:
Range("D3").Select
Range(Selection, Selection.End(xlDown)).Select
I think I want to use Application.WorksheetFunction.Proper.
Here is my approach to this, adjust the column index (rw.Row, 1) to suit your project
Sub ConvertValuesInColumnOneToProperCase()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rw As Range
For Each rw In ws.UsedRange.Rows
ws.Cells(rw.Row, 1) = StrConv(ws.Cells(rw.Row, 1), vbProperCase)
Next rw
End Sub
Please, try this way. The next code processes the values in column E:E. You can easily adapt it for another column. No need to select anything. Selecting, activating only consumes Excel resources without bringing any benefit:
Sub UcaseRange()
Dim sh As Worksheet, rng As Range
Set sh = ActiveSheet
Set rng = sh.Range("E2:E" & sh.Range("E" & sh.rows.count).End(xlUp).row)
rng = Evaluate("INDEX(UPPER(" & rng.Address(0, 0) & "),)")
End Sub
Update: I realized that I can't use union on multiple sheets.
What's the best choice that I have then?
I simply want to combine all sheets in the workbook into the first worksheet.
After I went through the existing questions, I've tried adding Set rng = nothing to clear my range, but it didn't help.
Sub Combine()
Dim J As Long
Dim Combine As Range
Dim rng As Range
'I want to start from the second sheet and go through all of them
For J = 2 To Sheets.Count
With Sheets(J)
Set rng = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
End With
For Each Cell In rng
If Combine Is Nothing Then
Set Combine = Cell.EntireRow
Else
Set Combine = Union(Combine, Cell.EntireRow)
End If
Next Cell
Set rng = Nothing
Next J
'Paste the whole union into the 1st sheet
Combine.Copy Destination:=Sheets(1).Range("A1")
End Sub
All this code gets me an error Method 'Union' of object '_Global failed
Update 2
Sub Combine2()
Dim rowcount As Long
For Each Sheet In Sheets
If Sheet.Index <> 1 Then
rowcount = Sheet.UsedRange.Rows.Count
Sheet.UsedRange.Copy Destination:=Sheets(1).Cells(Lastrow + 1, 1)
Lastrow = Lastrow + rowcount
End If
Next Sheet
End Sub
Really simple code, worked perfectly, thanks to #luuklag for leading me on this.
Indeed .Union method doesn't work across worksheets.
Instead, you could try looping through all your worksheets, copying the corresponding range and pasting it to the destination worksheet.
Something like the following would achieve this:
Sub test()
Dim destinationSheet As Worksheet
Dim sht As Worksheet
Dim destinationRng As Range
Dim rng As Range
Set destinationSheet = ThisWorkbook.Worksheets("Name of your worksheet")
For Each sht In ThisWorkbook.Worksheets
If sht.Name <> destinationSheet.Name Then
With sht
Set rng = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(xlUp))
rng.Copy
End With
With destinationSheet
Set destinationRng = .Range("A" & .Rows.Count).End(xlUp)
If destinationRng.Address = .Range("A1").Address Then
destinationRng.PasteSpecial xlPasteValues
Else
destinationRng.Offset(1, 0).PasteSpecial xlPasteValues
End If
End With
End If
Next sht
End Sub
The code above pastes the ranges one by one, in the same column. It can be easily modified to paste the ranges in different columns, one next to the other.
I have a template (named template in the code) and a list of store numbers ( named list in the code). I want to create a new worksheet identical to the template, but replace one cell (E5) with the next number in the list. I have this code but it doesn't seem to work. Any ideas? :
Sub CreateNewSheet()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("List").Range("A2") 'Must change tab name
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets("Template").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets("List").Select
MyCell.Select
Selection.Copy
Sheets(Sheets.Count).Select
Range("E5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets(Sheets.Count).Name = MyCell.Value & "-" ' renames the new worksheet
Range("E5").Select 'Puts driver name in cell
Next MyCell
End Sub
You are overwriting the range for one thing here:
Set MyRange = Sheets("List").Range("A2") 'Must change tab name
Set MyRange = Range(MyRange, MyRange.End(xlDown))
When I think you want to actually create the range to loop over. Note MyRange.End(xlDown) will take you down to the last non-blank cell in the range rather than the last used row.
So, I have changed your syntax to find the last row, stored in a variable, and use that to define the loop range.
lastRow = ws.Range("A2").End(xlDown).Row
Set MyRange = ws.Range("A2:A" & lastRow)
Then I have put the List worksheet in a variable so you don't need to go backwards and forward selecting sheets.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("List")
This means that whenever you add a sheet, which will become the activesheet, you can simply refer access the MyCell value as it is qualified by the sheet name it came from.
This,
Sheets(Sheets.Count).Name = MyCell.Value & "-"
Looks a bit dodgy in terms of naming. Sort of looks unfinished. However, that should be enough to get you going.
Option Explicit
Sub CreateNewSheet()
Dim MyCell As Range
Dim MyRange As Range
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Worksheets("List")
lastRow = ws.Range("A2").End(xlDown).Row
Set MyRange = ws.Range("A2:A" & lastRow)
Dim counter
For Each MyCell In MyRange
Sheets("Template").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet
ActiveSheet.Range("E5") = MyCell
Sheets(Sheets.Count).Name = MyCell.Value & "-" ' renames the new worksheet
Next MyCell
End Sub
I am trying to create a new worksheet, by copying the 'Template', if one does not exist.
The names of the sheets are based on Column A (list starting from A5 of the 'Master'). The list in 'Master' will be updated daily.
I check the list for new names by looping through the existing Sheets. If a cell in Column A (Sheet 'Master') already has a worksheet with the name, then do nothing and go to the next cell. If a name in the list is not among the sheetnames of the Workbook, a worksheet would be added (a copy of the 'Template') and named after the cell value.
I am able to create the new worksheets but for every existing worksheet, the macro creates additional worksheets ('template(2)', 'template(3)', 'template(4)', and so on).
What should I do to eliminate those new sheets of 'template(#)'?
Here is my code:
Sub AutoAddSheet()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Master").Range("A5")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
On Error Resume Next
Sheets("Template").Copy After:=Sheets(Sheets.Count)
With Sheets(Sheets.Count)
.Name = MyCell.Value
.Cells(2, 1) = MyCell.Value
End With
On Error GoTo 0
MyCell.Hyperlinks.Add Anchor:=MyCell, Address:="", SubAddress:="'" & MyCell.Value & "'!A1"
Next MyCell
End Sub
You could try it in a different way. First, loop through all Worksheets in the workbook and save their names in sheetNames array.
Then, for each cell in your range, you can use the Match function to see if it already exists in your workbook. If the Match fails, it means this MyCell.Value is not found in the worksheets names >> so create it.
Code
Option Explicit
Sub AutoAddSheet()
Dim MyCell As Range, MyRange As Range
Dim sheetNames() As String
Dim ws As Worksheet
Dim i As Integer
Set MyRange = Sheets("Master").Range("A5", Sheets("Master").Range("A5").End(xlDown))
' put all sheet name from Range A5 in "Master" sheet into an array
ReDim sheetNames(1 To 100) ' = Application.Transpose(MyRange.Value)
i = 1
' loop through all worksheets and get their names
For Each ws In Worksheets
sheetNames(i) = ws.Name
i = i + 1
Next ws
'resice array to actual number of sheets in workbook
ReDim Preserve sheetNames(1 To i - 1)
For Each MyCell In MyRange.Cells
' sheet name not found in workbook sheets array >> create it
If IsError(Application.Match(MyCell.Value, sheetNames, 0)) Then
Sheets("Template").Copy After:=Sheets(Sheets.Count)
With Sheets(Sheets.Count)
.Name = MyCell.Value
.Cells(2, 1) = MyCell.Value
End With
MyCell.Hyperlinks.Add Anchor:=MyCell, Address:="", SubAddress:="'" & MyCell.Value & "'!A1"
Else '<-- sheet name exists in array (don't create a new one)
' do nothing
End If
Next MyCell
' ====== Delete the worksheets with (#) section =====
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name Like "*(?)*" Then ws.Delete
Next ws
Application.DisplayAlerts = True
End Sub
You need to check if the sheet exists first, here's an efficient function I wrote to do so:
Function CheckSheetExists(ByVal name As String)
' checks if a worksheet already exists
Dim retVal As Boolean
retVal = False
For s = 1 To Sheets.Count
If Sheets(s).name = name Then
retVal = True
Exit For
End If
Next s
CheckSheetExists = retVal
End Function
So, amend your code to this:
If CheckSheetExists(MyCell.Value) = false then
Sheets("Template").Copy After:=Sheets(Sheets.Count)
With Sheets(Sheets.Count)
.Name = MyCell.Value
.Cells(2, 1) = MyCell.Value
End With
End If
I just tweaked your code a little to make sure all references were fully qualified. It should be easier to follow and you don't run the risk of Excel getting confused about where to copy from/to.
Tested and works for me
Sub AutoAddSheet()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Master").Range("A5")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Dim wksTemplate As Worksheet
Set wksTemplate = ThisWorkbook.Worksheets("Template")
For Each MyCell In MyRange
wksTemplate.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Dim wsNew As Worksheet
Set wsNew = ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
With wsNew
.Name = MyCell.Value
.Cells(2, 1) = MyCell.Value
End With
MyCell.Hyperlinks.Add Anchor:=MyCell, Address:="", SubAddress:="'" & MyCell.Value & "'!A1"
Next MyCell
End Sub