PDA

View Full Version : modify macro with hyperlink



preseb
10-04-2012, 01:13 PM
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.

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

p45cal
10-05-2012, 05:49 AM
try: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
There is a line:
.Hyperlinks.Add Anchor:=cll, Address:="", SubAddress:="'" & C.Value & "'!A" & rowNo 'use this instead to link to specific row
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.

preseb
10-05-2012, 11:24 AM
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