Forum Discussion
Excel VBA Inserting Links
Hey SergeiBaklan and HansVogelaar - either of you have ideas on what i'm missing? Trying to get the "create new user" (V2) macro to end with adding a hyperlink in cell A of the user list tab, which links to the newly created users tab. So far i managed to get a non-working link created on the appropriate new user line, but in the wrong field.
Here you go:
Sub CreateNewUserTabCCCCCV2() Dim WBK As Workbook Dim WSH As Worksheet Dim RNG1 As Range Dim RNG2 As Range Dim ADR1 As String Dim ADR2 As String Dim WSN As Worksheet Dim ID As Long Dim RowStart As String Dim RowEnd As String Dim EndAddress As String Dim StartAddress As String Dim StartMonth As String Dim StartRow As String Dim LR As Long 'Save and close other workbooks For Each WBK In Application.Workbooks If Not (WBK Is Application.ThisWorkbook) Then WBK.Close SaveChanges:=True End If Next WBK 'Find New Users on Productivity Tab Application.ScreenUpdating = False Set WBK = ThisWorkbook Set WSH = WBK.Worksheets("User List") With WSH.Range("F:F") Set RNG1 = .Find(What:="No", LookIn:=xlValues, Lookat:=xlWhole) If Not RNG1 Is Nothing Then ADR1 = RNG1.Address Set RNG2 = RNG1.Offset(0, -5) ADR2 = RNG2.Address Do If RNG2.Value <> "" Then ID = RNG2.Value StartMonth = RNG1.Offset(0, 1).Value 'Copy template to end of sheets WBK.Worksheets("Template").Copy After:=WBK.Worksheets(WBK.Worksheets.Count) Set WSN = WBK.Worksheets(WBK.Worksheets.Count) 'Update ID Cell and Tab Name on new sheet WSN.Range("B8").Value = ID WSN.Name = CStr(ID) 'Identify future month rows to remove WSN.Range("A11") = RowStart EndAddress = Cells(WorksheetFunction.Match(StartMonth, Range("A:A"), 0), 1).Address RowEnd = Range(EndAddress).Row WSN.Range("A11:A" & RowEnd - 1).EntireRow.Delete 'Identify pre-start month rows to remove StartAddress = Cells(WorksheetFunction.Match(StartMonth, Range("A:A"), 0), 1).Address RowStart = Range(StartAddress).Row LR = Cells(Rows.Count, 1).End(xlUp).Row WSN.Range("A" & RowStart + 1 & ":A" & LR).EntireRow.Delete 'Update New Sheet Caluclation References WSN.Range("B9").Formula = "=SUM($AL$11:$AL$33)" WSN.Range("G9").Formula = "=SUM($AO$11:$AO$33)" WSN.Range("J9").Formula = "=SUM($AM$11:$AM$33)" WSN.Range("N9").Formula = "=SUM($AN$11:$AN$33)" WSN.Range("Q9").Formula = "=SUM($AK$11:$AK$21)" WSN.Range("T9").Formula = "=SUM($AI$11:$AI$33)" WSN.Range("Y9").Formula = "=SUM($AH$11:$AH$33)" WSN.Range("AB9").Formula = "=SUM($AJ$11:$AJ$33)" WSN.Range("B1").Formula = "=B9" WSN.Range("B3").Formula = "=SUM(G9,J9,N9)" WSN.Range("B5").Formula = "=Q9" 'Update User List to create links to newly created user tabs WSH.Hyperlinks.Add Anchor:=RNG2, Address:="", SubAddress:="'" & WSN.Name & "'!A1" End If RNG1.Value = "Yes" Set RNG1 = .Find(What:="No", Lookat:=xlWhole) If RNG1 Is Nothing Then Exit Do Loop Until RNG1.Address = ADR1 End If End With WSH.Activate Application.ScreenUpdating = True End SubHansVogelaar stupid question time. It seems it works beautifully if i only have 1 new user to add. If i have more than one it behaves oddly, and errors on creating the second new user sheet. Behavior is as follows:
1. First new sheet created, cell b8 named, sheet named, and all un needed rows removed.
2. Next copy of "Template" created, but cell B8 is named the name of the sheet created in bullet 1. at the point the WSN.Name fires again, the macro errors, advising, best as i can translate, the sheet name is already taken by the previously created tab.Hope that makes sense, and can be recreated with the copy i'm attaching here. Again, this logic you had above, is now labelled the CreateNewV2.
I had to move three lines into the Do ... Loop.
Sub CreateNewUserTabCCCCCV2() Dim WBK As Workbook Dim WSH As Worksheet Dim RNG1 As Range Dim RNG2 As Range Dim ADR1 As String Dim ADR2 As String Dim WSN As Worksheet Dim ID As Long Dim RowStart As String Dim RowEnd As String Dim EndAddress As String Dim StartAddress As String Dim StartMonth As String Dim StartRow As String Dim LR As Long 'Save and close other workbooks For Each WBK In Application.Workbooks If Not (WBK Is Application.ThisWorkbook) Then WBK.Close SaveChanges:=True End If Next WBK 'Find New Users on Productivity Tab Application.ScreenUpdating = False Set WBK = ThisWorkbook Set WSH = WBK.Worksheets("User List") With WSH.Range("F:F") Set RNG1 = .Find(What:="No", LookIn:=xlValues, Lookat:=xlWhole) If Not RNG1 Is Nothing Then Do ADR1 = RNG1.Address Set RNG2 = RNG1.Offset(0, -5) ADR2 = RNG2.Address If RNG2.Value <> "" Then ID = RNG2.Value StartMonth = RNG1.Offset(0, 1).Value 'Copy template to end of sheets WBK.Worksheets("Template").Copy After:=WBK.Worksheets(WBK.Worksheets.Count) Set WSN = WBK.Worksheets(WBK.Worksheets.Count) 'Update ID Cell and Tab Name on new sheet WSN.Range("B8").Value = ID WSN.Name = CStr(ID) 'Identify future month rows to remove WSN.Range("A11") = RowStart EndAddress = WSN.Cells(WorksheetFunction.Match(StartMonth, WSN.Range("A:A"), 0), 1).Address RowEnd = WSN.Range(EndAddress).Row WSN.Range("A11:A" & RowEnd - 1).EntireRow.Delete 'Identify pre-start month rows to remove StartAddress = WSN.Cells(WorksheetFunction.Match(StartMonth, WSN.Range("A:A"), 0), 1).Address RowStart = WSN.Range(StartAddress).Row LR = WSN.Cells(WSN.Rows.Count, 1).End(xlUp).Row WSN.Range("A" & RowStart + 1 & ":A" & LR).EntireRow.Delete 'Update New Sheet Caluclation References WSN.Range("B9").Formula = "=SUM($AL$11:$AL$33)" WSN.Range("G9").Formula = "=SUM($AO$11:$AO$33)" WSN.Range("J9").Formula = "=SUM($AM$11:$AM$33)" WSN.Range("N9").Formula = "=SUM($AN$11:$AN$33)" WSN.Range("Q9").Formula = "=SUM($AK$11:$AK$21)" WSN.Range("T9").Formula = "=SUM($AI$11:$AI$33)" WSN.Range("Y9").Formula = "=SUM($AH$11:$AH$33)" WSN.Range("AB9").Formula = "=SUM($AJ$11:$AJ$33)" WSN.Range("B1").Formula = "=B9" WSN.Range("B3").Formula = "=SUM(G9,J9,N9)" WSN.Range("B5").Formula = "=Q9" 'Update User List to create links to newly created user tabs WSH.Hyperlinks.Add Anchor:=RNG2, Address:="", SubAddress:="'" & WSN.Name & "'!A1" End If RNG1.Value = "Yes" Set RNG1 = .Find(What:="No", After:=RNG1, Lookat:=xlWhole) If RNG1 Is Nothing Then Exit Do Loop Until RNG1.Address = ADR1 End If End With WSH.Activate Application.ScreenUpdating = True End Sub
