opening a folder then creating links

T

tim64

I have this code that converts web addresses into links in this file
that is created in another program. The problem is I have to copy the
code form where it is and then paste it in the file's, with the links,
VBE area. What I want is a message box to pop up so I can choose the
file, with the links, and then it copies and pastes the code
automaticly, then it runs the code.



Code:
--------------------

Sub MakeHyperlink()

Range("B7").Select
Dim strCellData As Variant

Do Until ActiveCell.Value = ""

strCellData = ActiveCell.Value
ActiveCell.Value = strCellData
ActiveCell.Offset(1, 0).Select
On Error Resume Next
'ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'0'!A1", TextToDisplay:="www.puritan.com"
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http:\\" & Selection.Value, TextToDisplay:=Selection.Value
Loop

Range("G7").Select

Do Until ActiveCell.Value = ""

strCellData = ActiveCell.Value
ActiveCell.Value = strCellData
ActiveCell.Offset(1, 0).Select
On Error Resume Next
'ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'0'!A1", TextToDisplay:="www.puritan.com"
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http:\\" & Selection.Value, TextToDisplay:=Selection.Value
Loop

Range("N7").Select

Do Until ActiveCell.Value = ""

strCellData = ActiveCell.Value
ActiveCell.Value = strCellData
ActiveCell.Offset(1, 0).Select
On Error Resume Next
'ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'0'!A1", TextToDisplay:="www.puritan.com"
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http:\\" & Selection.Value, TextToDisplay:=Selection.Value
Loop

Range("X7").Select

Do Until ActiveCell.Value = ""

strCellData = ActiveCell.Value
ActiveCell.Value = strCellData
ActiveCell.Offset(1, 0).Select
On Error Resume Next
'ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'0'!A1", TextToDisplay:="www.puritan.com"
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http:\\" & Selection.Value, TextToDisplay:=Selection.Value
Loop

Range("AG7").Select

Do Until ActiveCell.Value = ""

strCellData = ActiveCell.Value
ActiveCell.Value = strCellData
ActiveCell.Offset(1, 0).Select
On Error Resume Next
'ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'0'!A1", TextToDisplay:="www.puritan.com"
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http:\\" & Selection.Value, TextToDisplay:=Selection.Value
Loop

Range("AO7").Select

Do Until ActiveCell.Value = ""

strCellData = ActiveCell.Value
ActiveCell.Value = strCellData
ActiveCell.Offset(1, 0).Select
On Error Resume Next
'ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'0'!A1", TextToDisplay:="www.puritan.com"
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http:\\" & Selection.Value, TextToDisplay:=Selection.Value
Loop

End Sub
 
A

anilsolipuram

Backup your workbook before trying this macro.

I condensed the code,

range_copy is the range to be copied from, copy_to is the locatio
where it will be copied


Sub MakeHyperlink()
Dim v, file_name, o_file, n_file, range_copy, copy_to As Variant
v = Array("b", "G", "n""x", "ag", "ao")
range_copy = "b7:az30"
copy_to = "b7"
o_file = ActiveWorkbook.Name
file_name = Application.GetOpenFilename
Workbooks.Open Filename:=file_name
n_file = ActiveWorkbook.Name
Range(range_copy).Select
Selection.Copy
Workbooks(o_file).Activate
Range(copy_to).Select
ActiveSheet.Paste
Workbooks(n_file).Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
Workbooks(o_file).Activate
For i = 0 To UBound(v)
Range(v(i) & "7").Select
Do Until ActiveCell.Value = ""
strCellData = ActiveCell.Value
ActiveCell.Value = strCellData
ActiveCell.Offset(1, 0).Select
On Error Resume Next
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http:\\
& Selection.Value, TextToDisplay:=Selection.Value
Loop
Next
End Su
 
T

tim64

there's an error (see below)


Sub MakeHyperlink()
Dim v, file_name, o_file, n_file, range_copy, copy_to As Variant
v = Array("b", "G", "n""x", "ag", "ao")
range_copy = "b7:az30"
copy_to = "b7"
o_file = ActiveWorkbook.Name
file_name = Application.GetOpenFilename
Workbooks.Open Filename:=file_name <----------- run time error '1004'
n_file = ActiveWorkbook.Name
Range(range_copy).Select
Selection.Copy
Workbooks(o_file).Activate
Range(copy_to).Select
ActiveSheet.Paste
Workbooks(n_file).Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
Workbooks(o_file).Activate
For i = 0 To UBound(v)
Range(v(i) & "7").Select
Do Until ActiveCell.Value = ""
strCellData = ActiveCell.Value
ActiveCell.Value = strCellData
ActiveCell.Offset(1, 0).Select
On Error Resume Next
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http:\\"
Selection.Value, TextToDisplay:=Selection.Value
Loop
Next
End Su
 
A

anilsolipuram

Try this macro, and type in the error that popsup


Sub MakeHyperlink()
Dim v, file_name, o_file, n_file, range_copy, copy_to As Variant
v = Array("b", "G", "n", "x", "ag", "ao")
range_copy = "b7:az30"
copy_to = "b7"
o_file = ActiveWorkbook.Name
file_name = Application.GetOpenFilename

If file_name <> "" Then
On Error GoTo a:
Workbooks.Open Filename:=file_name
n_file = ActiveWorkbook.Name
Range(range_copy).Select
Selection.Copy
Workbooks(o_file).Activate
Range(copy_to).Select
ActiveSheet.Paste
Workbooks(n_file).Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
Workbooks(o_file).Activate
For i = 0 To UBound(v)
Range(v(i) & "7").Select
Do Until ActiveCell.Value = ""
strCellData = ActiveCell.Value
ActiveCell.Value = strCellData
ActiveCell.Offset(1, 0).Select
On Error Resume Next
ActiveSheet.Hyperlinks.Add Anchor:=Selection
Address:="http:\\" & Selection.Value, TextToDisplay:=Selection.Value
Loop
Next
End If
a:
MsgBox Err.Description
End Su
 
T

tim64

the MsgBox said "select method of range class failed "

Sub MakeHyperlink()
Dim v, file_name, o_file, n_file, range_copy, copy_to As Variant
v = Array("b", "G", "n", "x", "ag", "ao")
range_copy = "b7:az30"
copy_to = "b7"
o_file = ActiveWorkbook.Name
file_name = Application.GetOpenFilename

If file_name <> "" Then
On Error GoTo a:
Workbooks.Open Filename:=file_name
n_file = ActiveWorkbook.Name
Range(range_copy).Select <-------- it errors here
Selection.Copy
Workbooks(o_file).Activate
Range(copy_to).Select
ActiveSheet.Paste
Workbooks(n_file).Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
Workbooks(o_file).Activate
For i = 0 To UBound(v)
Range(v(i) & "7").Select
Do Until ActiveCell.Value = ""
strCellData = ActiveCell.Value
ActiveCell.Value = strCellData
ActiveCell.Offset(1, 0).Select
On Error Resume Next
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http:\\" &
Selection.Value, TextToDisplay:=Selection.Value
Loop
Next
End If
a:
MsgBox Err.Description
End Sub
 
A

anilsolipuram

now, what all msgs popsup

Sub MakeHyperlink()
Dim v, file_name, o_file, n_file, range_copy, copy_to As Variant
v = Array("b", "G", "n", "x", "ag", "ao")
range_copy = "b7:az30"
copy_to = "b7"
o_file = ActiveWorkbook.Name
file_name = Application.GetOpenFilename

If file_name <> "" Then
On Error GoTo a:
Workbooks.Open Filename:=file_name
n_file = ActiveWorkbook.Name
msgbox range_copy
Range(range_copy).Select
Selection.Copy
Workbooks(o_file).Activate
Range(copy_to).Select
ActiveSheet.Paste
Workbooks(n_file).Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
Workbooks(o_file).Activate
For i = 0 To UBound(v)
Range(v(i) & "7").Select
Do Until ActiveCell.Value = ""
strCellData = ActiveCell.Value
ActiveCell.Value = strCellData
ActiveCell.Offset(1, 0).Select
On Error Resume Next
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http:\\" &
Selection.Value, TextToDisplay:=Selection.Value
Loop
Next
End If
a:
MsgBox Err.Description
End Sub
 
A

anilsolipuram

I changed the range_copy, let me know wha popsup

Sub MakeHyperlink()
Dim v, file_name, o_file, n_file, range_copy, copy_to As Variant
v = Array("b", "G", "n", "x", "ag", "ao")
range_copy = "d10:d30"
copy_to = "b7"
o_file = ActiveWorkbook.Name
file_name = Application.GetOpenFilename

If file_name <> "" Then
Workbooks.Open Filename:=file_name
n_file = ActiveWorkbook.Name
msgbox range_copy
Range(range_copy).Select
Selection.Copy
Workbooks(o_file).Activate
Range(copy_to).Select
ActiveSheet.Paste
Workbooks(n_file).Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
Workbooks(o_file).Activate
For i = 0 To UBound(v)
Range(v(i) & "7").Select
Do Until ActiveCell.Value = ""
strCellData = ActiveCell.Value
ActiveCell.Value = strCellData
ActiveCell.Offset(1, 0).Select
On Error Resume Next
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http:\\" &
Selection.Value, TextToDisplay:=Selection.Value
Loop
Next
End If

End Sub
 
T

tim64

Sub MakeHyperlink()
Dim v, file_name, o_file, n_file, range_copy, copy_to As Variant
v = Array("b", "G", "n", "x", "ag", "ao")
range_copy = "d10:d30"
copy_to = "b7"
o_file = ActiveWorkbook.Name
file_name = Application.GetOpenFilename

If file_name <> "" Then
Workbooks.Open Filename:=file_name
n_file = ActiveWorkbook.Name
MsgBox range_copy <------- d10:d30
Range(range_copy).Select <----------- run time error '1004'
Selection.Copy
Workbooks(o_file).Activate
Range(copy_to).Select
ActiveSheet.Paste
Workbooks(n_file).Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
Workbooks(o_file).Activate
For i = 0 To UBound(v)
Range(v(i) & "7").Select
Do Until ActiveCell.Value = ""
strCellData = ActiveCell.Value
ActiveCell.Value = strCellData
ActiveCell.Offset(1, 0).Select
On Error Resume Next
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http:\\" &
Selection.Value, TextToDisplay:=Selection.Value
Loop
Next
End If

End Sub
 
A

anilsolipuram

It is working fine for me , i am not sure why it is not working for you.
Try this and let me know what popups


Sub MakeHyperlink()
Dim v, file_name, o_file, n_file, range_copy, copy_to As Variant
v = Array("b", "G", "n", "x", "ag", "ao")
range_copy = "a10:a30"
copy_to = "b7"
o_file = ActiveWorkbook.Name
file_name = Application.GetOpenFilename

If file_name <> "" Then
Workbooks.Open Filename:=file_name
n_file = ActiveWorkbook.Name
MsgBox range_copy
msgbox Range(cstr(range_copy)).address
Range(cstr(range_copy)).Select
Selection.Copy
Workbooks(o_file).Activate
Range(copy_to).Select
ActiveSheet.Paste
Workbooks(n_file).Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
Workbooks(o_file).Activate
For i = 0 To UBound(v)
Range(v(i) & "7").Select
Do Until ActiveCell.Value = ""
strCellData = ActiveCell.Value
ActiveCell.Value = strCellData
ActiveCell.Offset(1, 0).Select
On Error Resume Next
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http:\\" &
Selection.Value, TextToDisplay:=Selection.Value
Loop
Next
End If

End Sub
 
A

anilsolipuram

I am guessing probably the file you are opening is worksheet protected
or the some the are merged .

I want you create the new file add save it in c:\, and then test the
macro I sent you , now open the new_created file when file dialog comes
up.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

opening a file 14
Insert Hyperlink 4
Hyperlink macro for personal.xls 5
hyperlinking to charts in file 1
Hyperlinking cells and macros 2
Use Contents of a Cell to Create a Hyperlink 1
application.filesearch error in office 2010 3
Opening New Work with Wedpage Content when address is in original workbook 4

Top