PDA

View Full Version : [SOLVED] Copy content of Several Webpages



parscon
10-30-2013, 12:46 AM
IHi
I have thsi VBA code that can copy http://www.website.com/home/ and paste in excel now my question is i need to copy several page with different url
Like :
http://www.website.com/home/
copy above url and do run some code and again next url
http://www.website.com/Data2/
copy above url and do run some code and again next url
http://www.website.com/Apple/
copy above url and do run some code and again next url
http://www.domian.com/BoB/

Hope you will understand



Sub webCopier()
Dim lnk As Object, ie As Object, doc As Object, i As Long, R As Range, fAdr As String, nR As Long, cutRng As Range, Ar As Range, delAdr As String, LR As Long
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Visible = True
.navigate "http://www.website.com/home/"

Do Until .readyState = 4: DoEvents: Loop
Application.wait (Now() + TimeValue("00:00:5"))
Set doc = ie.document
.ExecWB 17, 0 '// SelectAll
.ExecWB 12, 2 '// Copy selection
.Quit
End With
Set ie = Nothing
Range("A1").Select
ActiveSheet.PasteSpecial Format:="Unicode Text", Link:=False, _
DisplayAsIcon:=False

'Some of my code will be place here.
End Sub

Jan Karel Pieterse
10-30-2013, 03:15 AM
Something like:



Sub Demo()
WebCopier "http://www.website.com/home/"
WebCopier "http://www.website.com/home/ (http://www.website.com/home/)"
WebCopier "http://www.website.com/Data2/ (http://www.website.com/Data2/)"
WebCopier "http://www.website.com/Apple/ (http://www.website.com/Apple/)"
WebCopier "http://www.domian.com/BoB/ (http://www.domian.com/BoB/)"
End Sub

Sub webCopier(sURL As String)
Dim lnk As Object, ie As Object, doc As Object, i As Long, R As Range, fAdr As String, nR As Long, cutRng As Range, Ar As Range, delAdr As String, LR As Long
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Visible = True
.navigate sURL

Do Until .readyState = 4: DoEvents: Loop
Application.wait (Now() + TimeValue("00:00:5"))
Set doc = ie.document
.ExecWB 17, 0 '// SelectAll
.ExecWB 12, 2 '// Copy selection
.Quit
End With
Set ie = Nothing
Range("A1").Select
ActiveSheet.PasteSpecial Format:="Unicode Text", Link:=False, _
DisplayAsIcon:=False

'Some of my code will be place here.
End Sub

Jan Karel Pieterse
10-30-2013, 03:17 AM
Something like:



Sub Demo()
WebCopier "http://www.website.com/home/"
WebCopier "http://www.website.com/home/"
WebCopier "http://www.website.com/Data2/"
WebCopier "http://www.website.com/Apple/"
WebCopier http://www.domian.com/BoB/
End Sub

Sub webCopier(sURL As String)
Dim lnk As Object, ie As Object, doc As Object, i As Long, R As Range, fAdr As String, nR As Long, cutRng As Range, Ar As Range, delAdr As String, LR As Long
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Visible = True
.navigate sURL

Do Until .readyState = 4: DoEvents: Loop
Application.wait (Now() + TimeValue("00:00:5"))
Set doc = ie.document
.ExecWB 17, 0 '// SelectAll
.ExecWB 12, 2 '// Copy selection
.Quit
End With
Set ie = Nothing
Range("A1").Select
ActiveSheet.PasteSpecial Format:="Unicode Text", Link:=False, _
DisplayAsIcon:=False

'Some of my code will be place here.
End Sub

mancubus
10-30-2013, 03:21 AM
Hi Jan.how about adding a worksheet/range parameter to sub where web contents will be pasted.

Jan Karel Pieterse
10-30-2013, 03:48 AM
You mean like so:



Sub Demo()
WebCopier "http://www.website.com/home/", Worksheets("Sheet2").Range("A2")
WebCopier "http://www.website.com/home/", Worksheets("Sheet2").Range("B2")
WebCopier "http://www.website.com/Data2/", Worksheets("Sheet2").Range("C2")
WebCopier "http://www.website.com/Apple/", Worksheets("Sheet2").Range("D2")
WebCopier "http://www.domian.com/BoB/", Worksheets("Sheet2").Range("E2")
End Sub

Sub webCopier(sURL As String, oDestination As Range)
Dim lnk As Object, ie As Object, doc As Object, i As Long, R As Range, fAdr As String, nR As Long, cutRng As Range, Ar As Range, delAdr As String, LR As Long
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Visible = True
.navigate sURL

Do Until .readyState = 4: DoEvents: Loop
Application.wait (Now() + TimeValue("00:00:5"))
Set doc = ie.document
.ExecWB 17, 0 '// SelectAll
.ExecWB 12, 2 '// Copy selection
.Quit
End With
Set ie = Nothing
Application.Goto oDestination
ActiveSheet.PasteSpecial Format:="Unicode Text", Link:=False, _
DisplayAsIcon:=False

'Some of my code will be place here.
End Sub

parscon
10-30-2013, 03:49 AM
It was my mistake and your code 100% work . Thank you very much .

parscon
10-30-2013, 04:09 AM
I found the problem just i must add Worksheets("Sheet1").Activate to end of my code .

Thank you very much . Really you save me .

Best Regards

mancubus
10-30-2013, 04:23 AM
You mean like so: exactly.:yes