I'm using the following code to copy a sheet. I also have a few named ranges that are scoped to the Workbook. The problem is, when I do the copy, it creates duplicates of all the named ranges with a scope of the new sheet. Everything works of course but I could potentially have 20+ sheets. I don't need 80 named ranges that are mostly duplicates. How can I avoid this?
Sub btnCopyTemplate()
Dim template As Worksheet
Dim newSheet As Worksheet
Set template = ActiveWorkbook.Sheets("Template")
template.Copy After:=Sheets(Sheets.Count)
Set newSheet = ActiveSheet
newSheet.Name = "NewCopy"
End Sub
And the Name Manager after a copy:
Here is my answer:
Sub btnCopyTemplate()
Dim template As Worksheet
Dim newSheet As Worksheet
Set template = ActiveWorkbook.Sheets("Template")
template.Copy After:=Sheets(Sheets.Count)
Set newSheet = ActiveSheet
newSheet.Name = "NewCopy"
deleteNames 'Check the sub
End Sub
Sub deleteNames()
Dim theName As Name
For Each theName In Names
If TypeOf theName.Parent Is Worksheet Then
theName.Delete
End If
Next
End Sub
This way you will delete all the names with the scope "worksheet" and keep the "workbook" names
Edit#2
After read the comments here is the update passing the sheet to loop only the "newSheet"
Sub btnCopyTemplate()
Dim template As Worksheet
Dim newSheet As Worksheet
Set template = ActiveWorkbook.Sheets("Template")
template.Copy After:=Sheets(Sheets.Count)
Set newSheet = ActiveSheet
newSheet.Name = "NewCopy"
deleteNames newSheet
End Sub
Sub deleteNames(sht As Worksheet)
Dim theName As Name
For Each theName In Names
If (TypeOf theName.Parent Is Worksheet) And (sht.Name = theName.Parent.Name) Then
theName.Delete
End If
Next
End Sub
Related
Going crazy here. I use this definition of worksheet all the time. Copied every string to avoid typing errors. Still, the code below produces "Nothing" when I try to set FR worksheet. Pls help!
Sub FindReplace()
Dim FRep As Worksheet
Dim c As Range
Dim cText As TextBox
Dim i As Integer
Set FRep = ThisWorkbook.Worksheets("FindReplace")
For i = 1 To 23
cText = FRep.Cells(i, 3).Text
FRep.Cells(i, 2).NumberFormat = "#"
FRep.Cells(i, 2).Value = cText
Next i
The code as is seems correct. Make sure that "FindReplace" worksheet is in ThisWorkbook.
Also, you can try to get "FindReplace" worksheet by CodeName instead of by the name of the sheet. The advantage is that if the user changes the name of the worksheet, the CodeName will remain the same and you won't need to update your code to the new worksheet name.
Public Function GetWsFromCodeName(codeName As String, wb As Workbook) As Worksheet
Dim ws As Worksheet
For Each ws In wb.Worksheets
If ws.CodeName = codeName Then
Set GetWsFromCodeName = ws
Exit For
End If
Next ws
End Function
Add this function in your code:
Sub FindReplace()
Dim FRep As Worksheet
Set FRep = GetWsFromCodeName("YourCodeName", ThisWorkbook)
So I have a pivottable and in column C there is field for which I am showing details for each record using this
For i=7 to 10
DATA.Range("C" & i).ShowDetail = True
Set wN = ThisWorkbook.Worksheets(1)
Next i
Now it works fine but the problem is Set wN = ThisWorkbook.Worksheets(1) assigns the wN the first worksheet but DATA.Range("C" & i).ShowDetail = True sometimes inserts the new worksheet which has the details at 1st or 2nd position. Now I want to know which was the new worksheet which was inserted and assign wN to it.
Do I have to make an array or list which keeps record of existing worksheets and then check which is the new one everytime? or there is an easy way to determine which is the newest worksheet in an workbook irrespective of the position.
Look at the Activesheet. ShowDetail creates the new sheet and activates it - so Set wn=ActiveSheet should work.
Sub Test()
Dim c As Range
Dim wrkSht As Worksheet
With ThisWorkbook.Worksheets("Sheet2").PivotTables(1)
For Each c In .DataBodyRange.Resize(, 1)
c.ShowDetail = True
Set wrkSht = ActiveSheet
Debug.Print wrkSht.Name
Next c
End With
End Sub
This link to Jon Peltiers page on Pivot Tables should be a massive help... https://peltiertech.com/referencing-pivot-table-ranges-in-vba/
The code shown does not add a worksheet, it sets wN to whatever sheet has index 1 (The second sheet created).
Try wN.Name = "C"& i & " field" to help figure out when each sheet is being created.
Open a new Workbook. Then run this code a few times:
Option Explicit
Public Sub TestMe()
Dim wsNew As Worksheet
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set wsNew = Worksheets(Worksheets.Count)
Debug.Print wsNew.Name
End Sub
You would see, that wsNew is always the last one added. Thus with Worksheetes(Worksheets.Count) you may access it.
Edit:
If you want to know the name of the last added Worksheet, without adding After:, then use collection to remember all the worksheets you had before and simply compare them with the new collection. Run this code a few times:
Option Explicit
Public Sub TestMe()
Dim wsCollection As New Collection
Dim lngCounter As Long
Dim strName As String
Dim blnNameFound As Boolean
Dim ws As Worksheet
For Each ws In Worksheets
wsCollection.Add ws.Name
Next ws
Worksheets.Add
For Each ws In Worksheets
blnNameFound = False
For lngCounter = 1 To wsCollection.Count
If wsCollection.Item(lngCounter) = ws.Name Then
blnNameFound = True
End If
Next lngCounter
If Not blnNameFound Then Debug.Print ws.Name
Next ws
End Sub
The complexity is O².
I have a workbook that will contain worksheets with the text “benefits” in the sheet name. For example; MEDICALBenefits or DENTALBenefits. There will always be at least one, but there could be several.
I am trying to write a macro that will find the worksheet(s) with the text “benefits” in the sheet name AND at least one instance of the word TRUE in row 40.
When these two criteria are met then I need to create a new worksheet using the same worksheet name but replacing the text “Benefits” with the text “Final”, In other words; If the worksheet MEDICALBenefits has TRUE in one or more cells in row 40 then a new sheet called MEDICALFinal would be created.
Likewise, if the worksheet DENTALBenefits has TRUE in one or more cells in row 40 then a new sheet called DENTALFinal would be created.
I then need it to loop through all the sheets looking for “Benefits” in the name and TRUE in row 40 and create a new sheet.
This is the code I have so far, but need help with naming the new sheets.
Jordan
'Look for worksheet names *benefits* with checkbox(s) = true
Sub CreateFinalWorksheet()
Dim sh As Worksheet
Dim iVal As Integer
Application.ScreenUpdating = False
For Each sh In ActiveWorkbook.Sheets
iVal = Application.WorksheetFunction.CountIf(Range("40:40"), "TRUE")
If (LCase$(sh.Name) Like "*benefits*") And (iVal > 0) Then Call AddWorksheet
Next sh
Application.ScreenUpdating = True
End Sub
'Called from CreateFinalWorksheet.
'Add worksheet with same sheet name replacing *benefits* with *final*
Sub AddWorksheet()
Dim sh As Worksheet
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "MedicalFinal"
End With
End Sub
edited after OPs clarification he wants to find all "*benefits" sheets
in
iVal = Application.WorksheetFunction.CountIf(Range("40:40"), "TRUE")
you're missing current sh worksheet reference, so you want to write as follows:
iVal = Application.WorksheetFunction.CountIf(sh.Range("40:40"), "TRUE")
For what above and for your main issue, I'd go like follows:
Sub CreateFinalWorksheet()
Dim sh As Worksheet
Application.ScreenUpdating = False
For Each sh In ActiveWorkbook.Sheets
If (LCase$(sh.Name) Like "*benefits") Then
If WorksheetFunction.CountIf(sh.Rows(40), "TRUE") = 0 Then AddWorksheet sh.Name
End If
Next sh
Application.ScreenUpdating = True
End Sub
Sub AddWorksheet(shtName As String)
Dim sh As Worksheet
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.count)).Name = Replace(LCase$(shtName), "benefits", "Final")
End With
End Sub
Add a parameter to your AddWorksheet routine, let it be the "benefits"worksheet
If (LCase$(sh.Name) Like "*benefits*") And (iVal > 0) Then AddWorksheet sh
Sub AddWorksheet(benef as worksheet)
....
ws.name = Replace(benef.name, "benefits", "Final", , vbTextCompare)
Eventually, you can also do other things inside this sub, such as copying some data from the parameter worksheet benef.
I have a workbook with a master sheet for school report cards. I have a macro applied to a button for exporting information from the master sheet to separate, newly-generated sheets in the same workbook. A1:C71 is the template and goes to every new sheet, and the following columns of info, from D1:71 to Q1:71, each appear in separate sheets (always in D1:71).
Here's the screenshot (http://imgur.com/a/ZDOVb), and here's the code:
`Option Explicit
Sub parse_data()
Dim studsSht As Worksheet
Dim cell As Range
Dim stud As Variant
Set studsSht = Worksheets("Input")
With CreateObject("Scripting.Dictionary")
For Each cell In studsSht.Range("D7:Q7").SpecialCells(xlCellTypeConstants, xlTextValues)
.Item(cell.Value) = .Item(cell.Value) & cell.EntireColumn.Address(False, False) & ","
Next
For Each stud In .keys
Intersect(studsSht.UsedRange, studsSht.Range(Left(.Item(stud), Len(.Item(stud)) - 1))).Copy Destination:=GetSheet(CStr(stud)).Range("D1")
Next
End With
studsSht.Activate
End Sub
Function GetSheet(shtName As String) As Worksheet
On Error Resume Next
Set GetSheet = Worksheets(shtName)
If GetSheet Is Nothing Then
Set GetSheet = Sheets.Add(after:=Worksheets(Worksheets.Count))
GetSheet.Name = shtName
Sheets("Input").Range("A1:C71").Copy
GetSheet.Range("A1:D71").PasteSpecial xlAll
GetSheet.Range("A1:B71").EntireColumn.ColumnWidth = 17.57
GetSheet.Range("C1:C71").EntireColumn.ColumnWidth = 54.14
GetSheet.Range("D1:D71").EntireColumn.ColumnWidth = 22
End If
End Function`
I would now like to create a separate button to split the sheets into separate workbooks so that the master sheet can be kept for record keeping and the individual workbooks can be shared with parents online (without divulging the info of any kid to parents other than their own). I would like the workbooks to be saved with the existing name of the sheet, and wonder if there's a way to have the new workbooks automatically saved in the same folder as the original workbook without having to input a path name? (It does not share the same filename as any of the sheets).
I tried finding other code and modifying it, but I just get single blank workbooks and I need as many as have been generated (preferably full of data!), which varies depending on the class size. Here's the pathetic attempt:
`Sub split_Reports()
Dim splitPath As String
Dim w As Workbook
Dim ws As Worksheet
Dim i As Long, j As Long
Dim lastr As Long
Dim wbkName As String
Dim wksName As String
Set wsh = ThisWorkbook.Worksheets(1)
splitPath = "G:\splitWb\"
Set w = Workbooks.Add
For i = 1 To lastr
wbkName = ws
w.Worksheets.Add(After:=w.Worksheets(Worksheets.Count)).Name = ws
w.SaveAs splitPath
w.Close
Set w = Workbooks.Add
Next i
End Sub`
I have learned so much, and yet I know so little.
Maybe this will start you off, just some simple code to save each sheet as a new workbook. You would probably need some check that the sheet name is a valid file name.
Sub x()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
ws.Copy
ActiveWorkbook.Close SaveChanges:=True, Filename:=ws.Name & ".xlsx"
Next ws
End Sub
I want a VBA code that rename my sheetXXX, where XXX is the value in the cell B5 in “Sheet1” sheet. The macro should work for any value in B5.
I tried the following code:
Sub tabname()
Dim sheetXXX As Worksheet
XXX.Name = Worksheets("Sheet1").Range("B5").Value
End Sub
You have to set the object = to the actual worksheet to be renamed.
Sub tabname()
Dim sheetXXX As Worksheet
Set sheetXXX = ActiveWorkbook.Sheets("sheetXXX")
sheetXXX.Name = "Sheet" & Worksheets("Sheet1").Range("B5").Value
End Sub
If sheetXXX is meant to be the active worksheet you would do this.
Sub tabname()
Dim sheetXXX As Worksheet
Set sheetXXX = ActiveWorkbook.Activesheet
sheetXXX.Name = "Sheet" & Worksheets("Sheet1").Range("B5").Value
End Sub