VBA to import From Web xml data from a column of URLs

[JacobBarton]

I have 5 columns of hyperlinks (A,B,C,D,E). Each column has 650 rows. The URLs contain xml data. Currently if I import a single URL From Web manually it creates a table with headers. I'd like to import the xml data from each column into it's own table on separate sheets. I'd like one table with a single header and all the data from each URL.

Column A to Sheet1, A1 import data to rows 1-10 (row one is the header), A2 rows 11-19 (no new header), A3 rows 20-28 (no new header), etc...

Column B to Sheet2...

What would be the most effective VBA approach?

 

[JacobBarton]

I've yet to really understand VBA... I've tried Macro Recorder but I don't know how to make it copy and paste from the cells. When I record it uses the actual text for the URL, not the cell.

 

[JacobBarton]

I found this but it's still confusing Excel Web Queries to Download a Database

 

[John_w]

Post your recorded macro for one of the URLs and we should be able to modify it to import data from all the URLs.

 

[JacobBarton]

Post your recorded macro for one of the URLs and we should be able to modify it to import data from all the URLs.

Thank you John. This is what I have so far:

Sub Macro5()
'
' Macro5 Macro
'

'
Range("A2").Select
ActiveCell.FormulaR1C1 = _
"http://nowphas.mlit.go.jp/nw-yugiha-point-xml.php?location=703&Date=20130101&days=1"
Range("A1").Select
ActiveWorkbook.XmlImport URL:= _
"http://nowphas.mlit.go.jp/nw-yugiha-point-xml.php?location=703&Date=20130101&days=1" _
, ImportMap:=Nothing, Overwrite:=True, Destination:=Range( _
"'MIYAKO WEST'!$A$1")
Sheets("Sheet5").Select
Range("A3").Select
ActiveCell.FormulaR1C1 = _
"http://nowphas.mlit.go.jp/nw-yugiha-point-xml.php?location=703&Date=20130102&days=1"
Range("A1").Select
ActiveWorkbook.XmlImport URL:= _
"http://nowphas.mlit.go.jp/nw-yugiha-point-xml.php?location=703&Date=20130102&days=1" _
, ImportMap:=Nothing, Overwrite:=True, Destination:=Range( _
"'MIYAKO WEST'!$A$74")
Sheets("MIYAKO WEST").Select
ActiveWindow.SmallScroll Down:=78
Sheets("Sheet5").Select
Range("A4").Select
ActiveCell.FormulaR1C1 = _
"http://nowphas.mlit.go.jp/nw-yugiha-point-xml.php?location=703&Date=20130103&days=1"
Range("A1").Select
With ActiveWorkbook.XmlMaps("data_nw_yugiha_point_Map4")
.ShowImportExportValidationErrors = False
.AdjustColumnWidth = True
.PreserveColumnFilter = True
.PreserveNumberFormatting = True
.AppendOnImport = True
End With
ActiveWorkbook.XmlImport URL:= _
"http://nowphas.mlit.go.jp/nw-yugiha-point-xml.php?location=703&Date=20130103&days=1" _
, ImportMap:=Nothing, Overwrite:=False, Destination:=Range( _
"'MIYAKO WEST'!$A$147")
Sheets("MIYAKO WEST").Select
ActiveWindow.SmallScroll Down:=18
End Sub

 

[John_w]

Try this. The URLs are expected to be in the first sheet of the workbook. Column A URLs start in A2, column B URLs start in B2, etc.

Public Sub XML_Import()

    Dim XmlURLs As Range, XmlURL As Variant
    Dim destCell As Range
    Dim col As Integer
    
    'Delete all XML maps
    
    While ActiveWorkbook.XmlMaps.Count > 0
        ActiveWorkbook.XmlMaps(1).Delete
    Wend
    
    'Loop through 5 columns, A to E
    
    For col = 1 To 5
    
        With Sheets(1)
            Set XmlURLs = .Range(.Cells(2, col), .Cells(Rows.Count, col).End(xlUp))
        End With
    
        Set destCell = Sheets(1 + col).Range("A1")
        destCell.Parent.Cells.Clear
        
        For Each XmlURL In XmlURLs
            
            If Not destCell Is Nothing Then
            
                'Import first XML data, creating a new XML mapping
                
                ActiveWorkbook.XmlImport URL:=XmlURL, ImportMap:=Nothing, overwrite:=False, Destination:=destCell
                Set destCell = Nothing
                
            Else
            
                'Append subsequent XML data using this sheet's mapping
                
                ActiveWorkbook.XmlMaps(col).Import URL:=XmlURL, overwrite:=False
            
            End If
            
        Next
    
    Next
    
End Sub

 

[JacobBarton]

John, that works perfect! Thank you so much. You saved me countless hours of frustration.

 

[JacobBarton]

I have another set of URLs that I'd like to do the same for but they do not show up as xml (although they are xml). An example is http://nowphas.mlit.go.jp/nw-kaimen-xml.php?location=702&date=20140101&mode=1d

I think it's an issue with the top line:
<code class="wrappedText focusRow" role="listitem"><!--?xml version="1.0" encoding="Shift_JIS" ?-->
<code class="wrappedText focusRow" role="listitem">?xml version="1.0" encoding="Shift_JIS" ?</code></pre>


The other pages start with:
<code class="wrappedText focusRow" role="listitem">
<code class="wrappedText focusRow" role="listitem">?xml version="1.0" encoding="Shift_JIS"?</code></pre>
</code>

</code>

 

[John_w]

I think the problem is that the opening tag:

< data_nw_kaimen

has a mismatched closing tag:

< /data_nw_choi>

(I have had to add a space after the '<' to prevent the forum rendering these tags as HTML.)

<data_nw_kaimen[ html]has="" a="" mismatched="" closing="" tag:
This code loads the XML data as a string and corrects the closing tag so that the XML can be imported without Excel thinking it is invalid. The nested Replaces are only needed to get around the problem of the forum rendering the HTML tags and so the code should work without you needing to edit it.

Public Sub XML_Import2()

    Dim XmlURLs As Range, XmlURL As Variant
    Dim destCell As Range
    Dim col As Integer
    
    'Delete all XML maps
    
    While ActiveWorkbook.XmlMaps.Count > 0
        ActiveWorkbook.XmlMaps(1).Delete
    Wend
    
    'Loop through 5 columns, A to E
    
    For col = 1 To 5
    
        With Sheets(1)
            Set XmlURLs = .Range(.Cells(2, col), .Cells(Rows.Count, col).End(xlUp))
        End With
    
        Set destCell = Sheets(1 + col).Range("A1")
        destCell.Parent.Cells.Clear
        
        For Each XmlURL In XmlURLs
            Debug.Print XmlURL.Value
            
            If Not destCell Is Nothing Then
            
                'Import first XML data, creating a new XML mapping
                
                ActiveWorkbook.XmlImportXml LoadAndFixXML(CStr(XmlURL)), importmap:=Nothing, Destination:=destCell
                Set destCell = Nothing
                
            Else
            
                'Append subsequent XML data using this sheet's mapping
                
                ActiveWorkbook.XmlMaps(col).ImportXml LoadAndFixXML(CStr(XmlURL)), overwrite:=False
            
            End If
            
        Next
    
    Next
    
End Sub


Private Function LoadAndFixXML(URL As String) As String

    Static XMLreq As Object
    
    If XMLreq Is Nothing Then Set XMLreq = CreateObject("MSXML2.XMLhttp")
    With XMLreq
        .Open "GET", URL, False
        .send
        
        'Change incorrect closing tag "< /data_nw_choi>" to "< /data_nw_kaimen>" (without the space in "< ")
        
        LoadAndFixXML = Replace(.responseText, Replace("< /data_nw_choi>", "< ", "<"), Replace("< /data_nw_kaimen>", "< ", "<"))
    End With

End Function

</data_nw_kaimen[>

 

[JacobBarton]

John, Thank you so much for all the help.