MACRO to Copy incl. hyperlinks
 

Hello,

I have found a nice macro wich copies contents (related to a value)
into different sheets wich saves alot of time. Works fine exept i have
Hyperlinks in column B and the names are copied but the hyperlinks are
gone. Don't know how to correct it so that it runs the macro and
copies column b so it maintains the hyperlink as org. column B.

With other words i think i need a line wich says: Keep html
formatting???

Option Explicit

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim Rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set Rng = Range("loader")

'extract a list of Sales Reps
ws1.Columns("c:c").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("L1"), Unique:=True
r = Cells(Rows.Count, "c").End(xlUp).Row
'set up Criteria Area
Range("Z1").Value = Range("c1").Value

For Each c In Range("L2:L" & r)
'add the rep name to the criteria area
ws1.Range("Z2").Value = c.Value
'add new sheet and run advanced filter
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
Rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("Z1:Z2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
'FIT WIDTH
Rows("1:1").EntireRow.AutoFit
Columns("A:A").ColumnWidth = 30.57
Columns("B:B").ColumnWidth = 30.57
Columns("C:C").ColumnWidth = 29.43
Columns("D:D").ColumnWidth = 33.14
Columns("E:E").ColumnWidth = 30
Columns("F:F").ColumnWidth = 19.57
Application.ScreenUpdating = False
Dim numRows As Integer
Dim r2 As Long
Dim Rng2 As Range
Dim lastrw As Long
numRows = 1
lastrw = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng2 = Range(Cells(2, "A"), Cells(lastrw, "A"))
For r2 = Rng.Rows.Count To 1 Step -1
Rng2.Rows(r2 + 1).Resize(numRows).EntireRow.Insert
Next r2
Application.ScreenUpdating = True

Next
ws1.Select
ws1.Columns("L:Z").Delete
End Sub


If someone could help, thanks a lot!
(could be that some rubbish is in the code, but it works for me :)

MACRO to Copy incl. hyperlinks
 

Maybe instead of using advanced filter to do the copy, it would be better to use
autofilter:

Option Explicit
Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim Rng As Range
Dim r As Integer
Dim c As Range
Dim RngToCopy As Range

Set ws1 = Sheets("Sheet1")
Set Rng = Range("loader")

With ws1
'get a list of unique entries
.Columns("c:c").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("L1"), _
Unique:=True

r = .Cells(.Rows.Count, "l").End(xlUp).Row

'cycle through that list
For Each c In Range("L2:L" & r).Cells
.AutoFilterMode = False
'filter by each value in that unique list
.Range("c1").EntireColumn.AutoFilter field:=1, Criteria1:=c.Value
Set RngToCopy = Intersect(.AutoFilter.Range.EntireRow, Rng)

Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
RngToCopy.Copy _
Destination:=wsNew.Range("a1")
Next c
.AutoFilterMode = False
End With

End Sub

I got rid of a lot of the stuff you added to Debra's code, but this skinnied
down version worked ok for me. (It kept the hyperlinks.)


wrote:

Hello,

I have found a nice macro wich copies contents (related to a value)
into different sheets wich saves alot of time. Works fine exept i have
Hyperlinks in column B and the names are copied but the hyperlinks are
gone. Don't know how to correct it so that it runs the macro and
copies column b so it maintains the hyperlink as org. column B.

With other words i think i need a line wich says: Keep html
formatting???

Option Explicit

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim Rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set Rng = Range("loader")

'extract a list of Sales Reps
ws1.Columns("c:c").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("L1"), Unique:=True
r = Cells(Rows.Count, "c").End(xlUp).Row
'set up Criteria Area
Range("Z1").Value = Range("c1").Value

For Each c In Range("L2:L" & r)
'add the rep name to the criteria area
ws1.Range("Z2").Value = c.Value
'add new sheet and run advanced filter
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
Rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("Z1:Z2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
'FIT WIDTH
Rows("1:1").EntireRow.AutoFit
Columns("A:A").ColumnWidth = 30.57
Columns("B:B").ColumnWidth = 30.57
Columns("C:C").ColumnWidth = 29.43
Columns("D:D").ColumnWidth = 33.14
Columns("E:E").ColumnWidth = 30
Columns("F:F").ColumnWidth = 19.57
Application.ScreenUpdating = False
Dim numRows As Integer
Dim r2 As Long
Dim Rng2 As Range
Dim lastrw As Long
numRows = 1
lastrw = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng2 = Range(Cells(2, "A"), Cells(lastrw, "A"))
For r2 = Rng.Rows.Count To 1 Step -1
Rng2.Rows(r2 + 1).Resize(numRows).EntireRow.Insert
Next r2
Application.ScreenUpdating = True

Next
ws1.Select
ws1.Columns("L:Z").Delete
End Sub

If someone could help, thanks a lot!
(could be that some rubbish is in the code, but it works for me :)

--

Dave Peterson

MACRO to Copy incl. hyperlinks
 

If you copy a cell containing a "clickable" hyperlink and paste it elsewhere,
the pasted cell should also contain a "clickable" hyper link:

Sub try_copy()
Set r1 = Range("A1")
Set r2 = Range("A2")
r1.Copy r2
End Sub


--
Gary''s Student - gsnu200715


" wrote:

Hello,

I have found a nice macro wich copies contents (related to a value)
into different sheets wich saves alot of time. Works fine exept i have
Hyperlinks in column B and the names are copied but the hyperlinks are
gone. Don't know how to correct it so that it runs the macro and
copies column b so it maintains the hyperlink as org. column B.

With other words i think i need a line wich says: Keep html
formatting???

Option Explicit

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim Rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set Rng = Range("loader")

'extract a list of Sales Reps
ws1.Columns("c:c").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("L1"), Unique:=True
r = Cells(Rows.Count, "c").End(xlUp).Row
'set up Criteria Area
Range("Z1").Value = Range("c1").Value

For Each c In Range("L2:L" & r)
'add the rep name to the criteria area
ws1.Range("Z2").Value = c.Value
'add new sheet and run advanced filter
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
Rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("Z1:Z2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
'FIT WIDTH
Rows("1:1").EntireRow.AutoFit
Columns("A:A").ColumnWidth = 30.57
Columns("B:B").ColumnWidth = 30.57
Columns("C:C").ColumnWidth = 29.43
Columns("D:D").ColumnWidth = 33.14
Columns("E:E").ColumnWidth = 30
Columns("F:F").ColumnWidth = 19.57
Application.ScreenUpdating = False
Dim numRows As Integer
Dim r2 As Long
Dim Rng2 As Range
Dim lastrw As Long
numRows = 1
lastrw = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng2 = Range(Cells(2, "A"), Cells(lastrw, "A"))
For r2 = Rng.Rows.Count To 1 Step -1
Rng2.Rows(r2 + 1).Resize(numRows).EntireRow.Insert
Next r2
Application.ScreenUpdating = True

Next
ws1.Select
ws1.Columns("L:Z").Delete
End Sub


If someone could help, thanks a lot!
(could be that some rubbish is in the code, but it works for me :)

MACRO to Copy incl. hyperlinks
 

Thanks, you are all awesome! It works like a charm!

Best Regards
J.Lemmens