Consulting

Results 1 to 3 of 3

Thread: modify macro with hyperlink

  1. #1

    modify macro with hyperlink

    I would like to add a hyperlink to my existing macro. I never created one, so I don’t know where to start. The file that I am using this on will break the information out into 1,000 different sheets – hence why I need the hyperlink.
    The macro current takes all of the data in column A – across and puts it into a separate worksheet with the name of what is in column A. I need the hyperlink in column A to go to that worksheet.

    Also I running into a problem where this macro stops creating worksheets after 42 sheets and I don’t know why.

    [vba]Sub exportws()
    Application.ScreenUpdating = False
    Dim i As Range, LR As Long, ws As Worksheet, wb As Workbook, C As Range
    Sheets("Sheet1").Select
    Range("A1").Select
    'looking at the full length of the file
    LR = Range("A" & Rows.Count).End(xlUp).Row
    'sheet needs to be named sheet1, all data should begin on row 3
    'column bb is an arbitrary column to filter the data
    Sheets("Sheet1").Range("A2:A" & LR).AdvancedFilter xlFilterCopy, copytorange:=Range("CC1"), unique:=True
    'add Variance Explain to bb1
    For Each C In Range("CC1:CC" & Range("CC" & Rows.Count).End(xlUp).Row)
    On Error GoTo 1
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = C.Value
    Next C
    1
    For Each C In Sheets("Sheet1").Range("CC1:CC" & Sheets("Sheet1").Range("CC" & Rows.Count).End(xlUp).Row)
    'field:=2 is selected to filter on - same as column b
    Sheets("Sheet1").Range("A1:az1").AutoFilter field:=1, Criteria1:=C.Value
    Sheets("Sheet1").Range("a2:az" & Sheets("Sheet1").Range("a" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy
    For Each ws In ThisWorkbook.Worksheets
    If ws.Name = C.Value Then
    ws.Range("a1").PasteSpecial xlPasteColumnWidths
    ws.Range("a1").PasteSpecial xlValue
    ws.Range("a1").PasteSpecial xlPasteFormats
    End If
    Next ws
    Sheets("Sheet1").Range("a2:az2").AutoFilter
    Application.CutCopyMode = False
    Next C
    Sheets("Sheet1").Columns("cc").Delete
    Sheets("Sheet1").Select
    Application.ScreenUpdating = True
    Range("A1").Select
    End Sub[/vba]
    Last edited by Aussiebear; 10-04-2012 at 10:05 PM. Reason: Added tags to code

  2. #2
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,875
    try:[vba]Sub exportws()
    Application.ScreenUpdating = False
    Dim i As Range, LR As Long, ws As Worksheet, wb As Workbook, C As Range
    With Sheets("Sheet1")
    'looking at the full length of the file
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    'sheet needs to be named sheet1, all data should begin on row 3
    'column bb is an arbitrary column to filter the data
    .Range("A2:A" & LR).AdvancedFilter xlFilterCopy, copytorange:=.Range("CC1"), unique:=True
    'add Variance Explain to bb1
    For Each C In .Range("CC1:CC" & .Range("CC" & Rows.Count).End(xlUp).Row)
    'On Error GoTo 1
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = C.Value
    Next C
    1
    For Each C In .Range("CC1:CC" & .Range("CC" & .Rows.Count).End(xlUp).Row)
    'field:=2 is selected to filter on - same as column b
    .Range("A1:az1").AutoFilter field:=1, Criteria1:=C.Value
    Set copysource = .Range("a2:az" & .Range("a" & .Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
    copysource.Copy
    With Worksheets(C.Value)
    .Range("a1").PasteSpecial xlPasteColumnWidths
    .Range("a1").PasteSpecial xlValue
    .Range("a1").PasteSpecial xlPasteFormats
    End With
    rowNo = 1
    For Each ar In copysource.Areas
    For Each cll In ar.Columns(1).Cells
    ' .Hyperlinks.Add Anchor:=cll, Address:="", SubAddress:="'" & C.Value & "'!A1" 'use this to link to cell A1
    .Hyperlinks.Add Anchor:=cll, Address:="", SubAddress:="'" & C.Value & "'!A" & rowNo 'use this instead to link to specific row
    rowNo = rowNo + 1
    Next cll
    Next ar
    .Range("a2:az2").AutoFilter
    Application.CutCopyMode = False
    Next C
    .Columns("cc").Delete
    Application.Goto .Range("A1")
    End With
    Application.ScreenUpdating = True
    End Sub
    [/vba]There is a line:
    [vba] .Hyperlinks.Add Anchor:=cll, Address:="", SubAddress:="'" & C.Value & "'!A" & rowNo 'use this instead to link to specific row
    [/vba]which links to the specific row in column A. If you want instead just to link to cell A1 of the sheet then replace that line with the commented out line above it (and you can delete the purple lines above too).
    I've commented out the On Error statement as it could lead to all sorts of problems - I prefer to know when there's an error.

    As to the 42 sheets problem (could it be related to the On Error statement?) - if it persists, come back.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  3. #3
    that is sweet! It works perfectly.

    As for the error - it was becuase the 43rd row contained a /. So I added a section to run through column A and remove all /.

    Thanks again

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •