With CreateObject("MSXML2.XMLHttp") .Open "GET", URL & SCT, False .SetRequestHeader "DNT", "1" On Error Resume Next .Send On Error GoTo 0 If .Status = 200 Then T$ = .ResponseText End With
If T > "" Then With CreateObject("HTMLFile") .write T If .parentWindow.clipboardData.setData("Text", .getElementsByTagName("TABLE")(3).outerHTML) Then Application.ScreenUpdating = False Me.Paste [B1]: Me.Hyperlinks.Delete .parentWindow.clipboardData.clearData "Text" Cells(2).Value = SCT: Cells(3).UnMerge: Cells(3).Copy [B2] Union([F2:G2], [I2:J2]).NumberFormat = "[$-809]mmm yyyy"
With Cells(2).CurrentRegion.Rows .Columns("B:D").Delete xlShiftToLeft For R& = .Count - 3 To 4 Step -5: .Item(R).Resize(4).Delete xlShiftUp: Next .RowHeight = 18.75: .VerticalAlignment = xlCenter: .WrapText = False .Item(2).Font.Size = 10: .Item(2).HorizontalAlignment = xlCenter .Columns(1).IndentLevel = 1: .Columns(1).AutoFit With .Item("3:" & .Count).Columns("B:G") .UnMerge: .HorizontalAlignment = xlRight: .IndentLevel = 1 End With For R = 3 To .Count Step 2 With .Item(R): .Interior.ColorIndex = CI: .Borders.ColorIndex = 15: End With Next End With End If End With End If If [E5].Value Like UPD & "*" Then [E5].Clear: Beep End Sub
Do you like it ? So thanks to click on bottom left star icon « Add Reputation » !
Last edited by Marc L; 09-07-2015 at 10:46 AM.
Reason: optimization …
I succeed to post code on another forums, problem only here !
I found out the source issue codeline : #51. Issue gone with mod of each Replace to Replace$ ! …
What a waste of time ‼
Paste next code to worksheet module, run the new demonstration and see the result after a while (~ 4 min) :
PHP Code:
Sub QTFormat(Rg As Range, SECTOR$, CI) With Rg.Rows .Cells(1).Value = SECTOR: .Cells(2, 1).Value = .Cells(2).Value .Range("E1:G1").Select: Selection.HorizontalAlignment = xlCenterAcrossSelection .Range("H1:J1").Select: Selection.HorizontalAlignment = xlCenterAcrossSelection .Item("1:2").Font.Bold = True: .Item(2).HorizontalAlignment = xlCenter For R& = .Count - 1 To 4 Step -3: .Item(R).Resize(2).Delete xlShiftUp: Next .RowHeight = 18: .VerticalAlignment = xlCenter .Columns(1).IndentLevel = 1 With .Item("3:" & .Count).Columns("E:J") .HorizontalAlignment = xlRight: .IndentLevel = 1 End With For R = 1 To .Count Step 2 With .Item(R): .Interior.ColorIndex = CI: .Borders.ColorIndex = 15: End With Next End With End Sub
Sub DemoQ() Const URL = "http://www.moneycontrol.com/stocks/cptmarket/sector/qtrlist.php?class=" Dim Rg As Range Application.Goto Cells(1), True With Me.UsedRange: .Clear: .Rows.RowHeight = Me.StandardHeight: End With Cells(2, 5).Value = " Downloads in progress …" Application.ScreenUpdating = False With Me.QueryTables.Add("URL;" & URL, Cells(2)) .AdjustColumnWidth = False .RefreshStyle = xlOverwriteCells .WebFormatting = xlWebFormattingNone .WebSelectionType = xlEntirePage .WebDisableDateRecognition = True On Error Resume Next .Refresh False If Err.Number Then Beep: Me.UsedRange.Clear: .Delete: Exit Sub On Error GoTo 0 With .ResultRange.Rows Set Rg = .Columns(1).Find("Aluminium", , , xlWhole) If Rg Is Nothing Then Beep: Me.UsedRange.Clear: Exit Sub SCT = Rg.CurrentRegion.Value Set Rg = .Columns(2).Find("Company Name", Rg(1, 2)) If Rg Is Nothing Then Beep: Me.UsedRange.Clear: Exit Sub .Item(Rg.Row + Rg(3, 0).CurrentRegion.Rows.Count + 2 & ":" & .Count).Delete .Item("1:" & Rg.Row - 1).Delete xlShiftUp Set Rg = Nothing: CT = [{19,35}]: QTFormat .Cells, (SCT(1, 1)), CT(1) End With .Delete End With
For R& = 2 To UBound(SCT) With Me.QueryTables.Add("URL;" & URL & Replace$(Replace$(SCT(R, 1), " ", "+"), "&", "%26"), _ Cells(Rows.Count, 2).End(xlUp)(4)) .AdjustColumnWidth = False .RefreshStyle = xlOverwriteCells .WebFormatting = xlWebFormattingNone .WebSelectionType = xlSpecifiedTables .WebTables = "4" .WebDisableDateRecognition = True .Refresh False: N% = 2 + (N% = 2) QTFormat .ResultRange, (SCT(R, 1)), CT(N): .Delete End With Next Cells(1).Select With Me.UsedRange: .Columns("B:D").Delete xlShiftToLeft: .Columns(1).AutoFit: End With End Sub
Do you like it ? So thanks to click on bottom left star icon « Add Reputation » !
Last edited by Marc L; 09-07-2015 at 09:11 AM.
Reason: optimizing …
Since more than one year you had time to learn how works a QueryTable within Excel !
As I do not remember your need, first check website new address
and update code accordingly … Do not forget Macro recorder !
Bookmarks