Umid's webPl.Ace

This Excel 2003 VBA code applies XML mapping of one Excel workbook to another workbook.


Sub remap()
'this functions iterates trough mapped workbook (workbook_from) and
'applies same XML mapping to identical cells of not mapped workbook (workbook_to)
'XML map file must be added to Workbook_To before running this code
Dim Workbook_From, Workbook_To As Workbook
Dim currentMap As XmlMap
Dim rCell As Range
'get xml mapping of this workbook:
Set Workbook_From = Workbooks("xml_mapped_excel_workbook.xls")
'apply xml mapping to this workbook:
Set Workbook_To = Workbooks("not_xml_mapped_excel_workbook.xls")
Debug.Print Workbook_To.XmlMaps.Item(1)
Set currentMap = Workbook_To.XmlMaps.Item(1)
On Error Resume Next
Application.DisplayAlerts = False
For Each wsheet In Workbook_From.Worksheets
RemoveAllXMLMappings Workbook_To.Worksheets(wsheet.Name)
For Each rCell In wsheet.UsedRange.Cells
If rCell.XPath <> "" Then
Workbook_To.Worksheets(wsheet.Name).Range(rCell.Address).XPath.SetValue currentMap, rCell.XPath
End If
Next rCell
DoEvents
Next wsheet
End Sub
Sub RemoveAllXMLMappings(wks As Worksheet)
Dim rCell As Range
For Each rCell In wks.UsedRange.Cells
If rCell.XPath <> "" Then
rCell.XPath.Clear
End If
Next
End Sub