OZmium Sports Betting and Horse Racing Forums - View Single Post

I have found a solution to this problem thanks to a user on the Gruss forum, he uses some macros to change 10:1-2-0 to 10::1-2-0 the double :: confuses excel and stops it changing to a date format.

I will post the macro but i don't totally understand it but it works, there are 3 parts to the macro.

The part in red in macro 3 is what he has added to my macro.

Forgot to mention what ever he has done has changed the import time from 30 seconds a race to 5 seconds.

Code:


Public Function ExecuteWebRequest(url As String) As String
    Dim oXHTTP As Object
    Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
    oXHTTP.Open "GET", url, False
    oXHTTP.send
    ExecuteWebRequest = oXHTTP.responseText
    Set oXHTTP = Nothing
End Function

Code:


Public Function outputtext(text As String)
Dim MyFile As String, fnum As String
        MyFile = ThisWorkbook.Path & "\temp.txt"
        fnum = FreeFile()
        Open MyFile For Output As fnum
        Print #fnum, text
        Close #fnum
End Function

Code:


Sub form()
Sheets("Form").Select
    Sheets("Form").Range("B1:J1000").Select
    Selection.ClearContents
    Columns("B:J").Select
    Selection.NumberFormat = "@"
    formhtml = ExecuteWebRequest(ThisWorkbook.Sheets("Data").Range("A1").Value)
    formhtml = Replace(formhtml, ":", "::")
    outputtext (formhtml)
    
    Set temp_qt = ThisWorkbook.Sheets("Form").QueryTables.Add(Connection:= _
            "URL;" & ThisWorkbook.Path & "\temp.txt" _
            , Destination:=ThisWorkbook.Sheets("Form").Range("B1"))
    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.Connect  ions.Count).Delete

Columns("B:J").Select
    Selection.Copy
    Application.DisplayAlerts = False
    Sheets("Data").Select
    Range("AA1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("AA:AA").Select
    Application.CutCopyMode = False
    Selection.TextToColumns Destination:=Range("AA1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
        ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1)), _
        TrailingMinusNumbers:=True
        Columns("AC:AC").Select
    Selection.TextToColumns Destination:=Range("AC1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 5), TrailingMinusNumbers:=True
        Application.DisplayAlerts = True
        Range("A1").Select
        
End Sub