Excel cell format change

[Shaun]

Yes i had a look at it a bit more closely, from what i remember that other sheet i mentioned used the same idea, i will have to learn this as it is much faster and i could use it for all my web queries.

[Shaun]

Using this script has taken a 35 second per race download to less then 5 seconds, i should have been using this all along.

Thank you.

[Shaun]

If it is not to much trouble i am trying to understand this code so i can use it in other web queries and am stuck with this macro on what to include in the first part as indicated with red text.

I also don't need to change any : so that could be removed i just need to download it.

Code: Select all


Sub Meetings1()
    Sheets("Meetings1").Select
    Sheets("Meetings1").Range("A1:H500").Select
    Selection.ClearContents
    Sheets("Meetings1").Range("W1:W500").Select
    Selection.ClearContents
     

formhtml = ExecuteWebRequest(ThisWorkbook.Sheets("Data").Range("A1").Value)

Code: Select all

 outputtext (formhtml)
   
    Set temp_qt = ThisWorkbook.Sheets("Meetings1").QueryTables.Add(Connection:= _
            "URL;http://formguide.cyberhorse.com.au/index.php/Form/view-form.html?formdate=" & _
        Format(Sheets("Data").Range("M2").Value, "yyyy-mm-dd") & ThisWorkbook.Path & "\temp.txt" _
            , Destination:=ThisWorkbook.Sheets("Meetings1").Range("$A$1"))
    With temp_qt
        .Name = False
        .FieldNames = False
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .Refresh BackgroundQuery:=False
    End With
    Columns("A:A").Select
    With Selection
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Sheets("Data").Select
    Range("AV1:AV500").Select
    Selection.ClearContents
    Sheets("Meetings1").Select
    Range("A1:A500").Select
    Selection.Copy
    Sheets("Data").Select
    Range("AV1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Data").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Data").Sort.SortFields.Add Key:=Range("AV1:AV1162" _
        ), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Data").Sort
        .SetRange Range("AV1:AV1162")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("RaceList").Select
    Range("K2:L2").Select
    End Sub



[osknows]

Code: Select all

Sub Meetings1()
    Sheets("Meetings1").Select
    Sheets("Meetings1").Range("A1:H500").Select
    Selection.ClearContents
    Sheets("Meetings1").Range("W1:W500").Select
    Selection.ClearContents
     

    formhtml = ExecuteWebRequest("http://formguide.cyberhorse.com.au/index.php/Form/view-form.html?formdate=" & _
        Format(Sheets("Data").Range("M2").Value, "yyyy-mm-dd"))

    outputtext (formhtml)
   
    Set temp_qt = ThisWorkbook.Sheets("Meetings1").QueryTables.Add(Connection:= _
            "URL;" & ThisWorkbook.Path & "\temp.txt" _
            , Destination:=ThisWorkbook.Sheets("Meetings1").Range("$A$1"))
    With temp_qt
        .Name = "test"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlAllTables
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = True
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Set temp_qt = Nothing
    Kill ThisWorkbook.Path & "\temp.txt"
    If ThisWorkbook.Connections.Count > 0 Then ThisWorkbook.Connections.Item(ThisWorkbook.Connections.Count).Delete
   
    Columns("A:A").Select
    With Selection
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Sheets("Data").Select
    Range("AV1:AV500").Select
    Selection.ClearContents
    Sheets("Meetings1").Select
    Range("A1:A500").Select
    Selection.Copy
    Sheets("Data").Select
    Range("AV1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Data").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Data").Sort.SortFields.Add Key:=Range("AV1:AV1162" _
        ), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Data").Sort
        .SetRange Range("AV1:AV1162")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("RaceList").Select
    Range("K2:L2").Select
    End Sub


[Shaun]

I thought it might have been like that but was not sure, thanks again.

[Shaun]

Hi again, i set this up on another part of the sheet to import the links for individual races but the problem i had was it removed the hyperlinks, is there any way around this.

Here is the macro i use to convert hyperlinks to actual text so i can use this to get the pages i need.

Code: Select all

Function GetAddress(HyperlinkCell As Range)
    GetAddress = Replace _
    (HyperlinkCell.Hyperlinks(1).Address, "mailto:", "")
End Function

[Shaun]

I just noticed extra code in what you sent me the other day and had a question about that.

this line

Code: Select all

If ThisWorkbook.Connections.Count > 0 Then ThisWorkbook.Connections.Item(ThisWorkbook.Connections.Count).Delete

Does that do the same as this because i use this in my code already.

Code: Select all

Dim qt As QueryTable
     Dim WSh As Worksheet

     For Each WSh In ThisWorkbook.Worksheets
          For Each qt In WSh.QueryTables
               qt.Delete
          Next qt
     Next WSh


[osknows]

Hi Shaun,

Send the link to the function first, eg

URL = .range("A1").value
cleanURL = GetAddress(URL)
formhtml = ExecuteWebRequest(cleanURL)

Your code for deleting querytables is fine, the only difference is my version will delete any type of connection and not just querytables.

[Shaun]

So they are both doing the same job correct?

If this is the case i will remove mine as your is doing fine.