Sub MCR()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'xlXmlImportElementsTruncated 1 - The contents of the specified XML data file have been truncated because the XML data file is too large for the worksheet.
'xlXmlImportSuccess 0 - The XML data file was successfully imported.
'xlXmlImportValidationFailed 2 - The contents of the XML data file do not match the specified schema map.
' http://www.bettersolutions.com/excel/ERV283/NO328968332.htm
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Response = MsgBox("Do you want to start import now ?", _
vbYesNo + vbCritical + vbDefaultButton2, _
"Import from WEB")
If Response = vbNo Then Exit Sub
Application.ScreenUpdating = False ' turn off the screen updating
Application.DisplayAlerts = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Procedure for xml file-import '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''ChDir (ActiveWorkbook.Path)
'fopen = Application.GetOpenFilename("XML Spreadsheet files (*.xml), *.xml")
' If fopen <> False Then
' With ActiveWorkbook
' .XmlMaps("Main_Map").Import URL:=fopen, Overwrite:=True
' End With
' Else
' MsgBox "Please select the xml file to import": Exit Sub
' End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Worksheets("Work")
If .Range("Criteria").Value = "" Or .Range("CriteriaX").Value = "" Or .Range("Criteria").Value > .Range("CriteriaX").Value Then MsgBox "Problema din perioda": Exit Sub
If .Range("pass").Value = "" Then MsgBox "Check password in $O$1 cell": Exit Sub
d_from = Format(.Range("Criteria").Value, "yyyy-mm-dd") & " 00:00:00"
d_to = Format(.Range("CriteriaX").Value, "yyyy-mm-dd") & " 23:59:59"
spass = .Range("pass").Value
End With
sdata = "<methodCall><methodName>authentication</methodName><params><param><value><int>837</int></value></param><param><value><string>adminVA</string></value></param><param><value><string>" & spass & "</string></value></param></params></methodCall>"
Set objHTTP = CreateObject("MSXML2.XMLHTTP")
URL = "http://export.***********.com"
objHTTP.Open "POST", URL, False
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.send (sdata)
If objHTTP.Status <> 200 Then MsgBox "HTTP Error: " & objHTTP.Status: Exit Sub
rdata = "<methodCall><methodName>getPolicyXML</methodName><params><param><value><string>" & objHTTP.ResponseXML.Text & "</string></value></param><param><value><boolean>1</boolean></value></param><param><value><string>" & d_from & "</string></value></param><param><value><string>" & d_to & "</string></value></param></params></methodCall>"
objHTTP.Open "POST", URL, False
objHTTP.send (rdata)
If objHTTP.Status <> 200 Then MsgBox "HTTP Server Error: " & objHTTP.Status: Exit Sub
For Each xFields In objHTTP.ResponseXML.DocumentElement.childNodes
Select Case UCase(xFields.nodeName)
Case "POLICIES"
For Each xNodes In xFields.childNodes
If xNodes.selectSingleNode(".//ProductID").nodeTypedValue <> "10" Then xFields.removeChild xNodes
Next
End Select
Next xFields
With ActiveWorkbook
.XmlMaps("Main_Map").ImportXml XMLData:=objHTTP.ResponseXML.XML, Overwrite:=True
End With
Set objHTTP = Nothing
MsgBox "Report data were successfully downloaded" & vbNewLine & "from WEB" & vbNewLine & "Wait for data import...."
Application.DisplayAlerts = True
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'1. =IF(ISBLANK(INDEX(XML!B4:B4000;0;0));"";INDEX(XML!B4:B4000;0;0)&TEXT(INDEX(XML!C4:C4000;0;0);"00000"))
'2. =IF(ISBLANK(INDEX(XML!D4:D4000;0;0));"";INDEX(XML!D4:D4000;0;0)&CHAR(32)&INDEX(XML!E4:E4000;0;0))
'3. =IF(ISBLANK(INDEX(XML!F4:F4000;0;0));"";INDEX(XML!F4:F4000;0;0))
'4. =IF(ISBLANK(INDEX(XML!G4:G4000;0;0));"";INDEX(XML!G4:G4000;0;0))
'5. =IF(ISBLANK(INDEX(XML!H4:H4000;0;0));"";INDEX(XML!H4:H4000;0;0))
'6. =IF(ISBLANK(INDEX(XML!I4:I4000;0;0));"";INDEX(XML!I4:I4000;0;0))
'7. =IF(ISBLANK(INDEX(XML!J4:J4000;0;0));"";INDEX(XML!J4:J4000;0;0))
'8. =IF(ISNA(VLOOKUP(INDEX(XML!L4:L4000;0;0);XML!V4:W477;2;FALSE));"";VLOOKUP(INDEX(XML!L4:L4000;0;0);XML!V4:W477;2;FALSE))
'9. =IF(ISBLANK(INDEX(XML!K4:K4000;0;0));"";INDEX(XML!K4:K4000;0;0))
'10. =IF(ISNA(VLOOKUP(INDEX(XML!M4:M4000;0;0);XML!Y4:Z17;2;FALSE));"";VLOOKUP(INDEX(XML!M4:M4000;0;0);XML!Y4:Z17;2;FALSE))
'11. =IF(XML!P4:P4000="refund";0;IF(XML!P4:P4000="void";0;IF(ISBLANK(INDEX(XML!N4:N4000;0;0));"";INDEX(XML!N4:N4000;0;0))))
'12. =IF(ISBLANK(INDEX(XML!O4:O4000;0;0));"";INDEX(XML!O4:O4000;0;0))
'13. =IF(ISBLANK(INDEX(XML!P4:P4000;0;0));"";INDEX(XML!P4:P4000;0;0))
'14. =IF(ISBLANK(INDEX(XML!B4:B4000;0;0));"";INDEX(XML!B4:B4000;0;0))
'15. =IF(ISBLANK(INDEX(XML!Q4:Q4000;0;0));"";IF(DATEDIF(D9:D4000;G9:G4000;"d")<=365;0;IF(DATEDIF(D9:D4000;G9:G4000;"d")<=4380;INDEX(XML!Q4:Q4000;0;0)*(1-20%);INDEX(XML!Q4:Q4000;0;0))))
'16. =IF(ISBLANK(INDEX(XML!A4:A4000;0;0));"";INDEX(XML!A4:A4000;0;0))
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.DisplayStatusBar = True
Application.StatusBar = "Please wait..."
With Worksheets("XML")
tbl_xml = .Range("A4").CurrentRegion.Rows.Count
.Range("B1").Value = Left(.Range("B1").Value, 10) & Chr(32) & Mid(.Range("B1").Value, 11)
End With
With Worksheets("Work")
If Range("sb_total").Offset(-3, 0).HasArray = True Then
Range("sb_total").Offset(-3, -10).CurrentArray.Resize(ColumnSize:=16).ClearContents
End If
tbl = .Range("tbl_end").Row - 5
If tbl < tbl_xml + 8 Then
' Range("B10").Select
' Selection.Resize(rowsize:=2).Rows(2).EntireRow.Resize(rowsize:=tbl_xml - tbl + 7).Insert Shift:=xlDown
Rows(10 & ":" & tbl_xml - tbl + 17).Insert Shift:=xlDown
' For i = 0 To tbl_xml - tbl + 7
' .Range("B10").EntireRow.Insert
' Next
ElseIf tbl > tbl_xml + 8 Then
Rows(10 & ":" & tbl - tbl_xml + 1).EntireRow.Delete ' -9 + Row(10)
' For i = 0 To tbl - tbl_xml - 9
' .Range("B10").EntireRow.Delete
' Next
Else
End If
.Range("B9" & ":" & "B" & tbl_xml + 8).FormulaArray = "=IF(ISBLANK(INDEX(XML!R4C2:R4000C2,0,0)),"""",INDEX(XML!R4C2:R4000C2,0,0)&TEXT(INDEX(XML!R4C3:R4000C3,0,0),""00000""))"
.Range("C9" & ":" & "C" & tbl_xml + 8).FormulaArray = "=IF(ISBLANK(INDEX(XML!R4C4:R4000C4,0,0)),"""",INDEX(XML!R4C4:R4000C4,0,0)&CHAR(32)&INDEX(XML!R4C5:R4000C5,0,0))"
.Range("D9" & ":" & "D" & tbl_xml + 8).FormulaArray = "=IF(ISBLANK(INDEX(XML!R4C6:R4000C6,0,0)),"""",INDEX(XML!R4C6:R4000C6,0,0))"
.Range("E9" & ":" & "E" & tbl_xml + 8).FormulaArray = "=IF(ISBLANK(INDEX(XML!R4C7:R4000C7,0,0)),"""",INDEX(XML!R4C7:R4000C7,0,0))"
.Range("F9" & ":" & "F" & tbl_xml + 8).FormulaArray = "=IF(ISBLANK(INDEX(XML!R4C8:R4000C8,0,0)),"""",INDEX(XML!R4C8:R4000C8,0,0))"
.Range("G9" & ":" & "G" & tbl_xml + 8).FormulaArray = "=IF(ISBLANK(INDEX(XML!R4C9:R4000C9,0,0)),"""",INDEX(XML!R4C9:R4000C9,0,0))"
.Range("H9" & ":" & "H" & tbl_xml + 8).FormulaArray = "=IF(ISBLANK(INDEX(XML!R4C10:R4000C10,0,0)),"""",INDEX(XML!R4C10:R4000C10,0,0))"
.Range("I9" & ":" & "I" & tbl_xml + 8).FormulaArray = "=IF(ISNA(VLOOKUP(INDEX(XML!R4C12:R4000C12,0,0),XML!R4C23:R480C24,2,FALSE)),"""",VLOOKUP(INDEX(XML!R4C12:R4000C12,0,0),XML!R4C23:R480C24,2,FALSE))"
.Range("J9" & ":" & "J" & tbl_xml + 8).FormulaArray = "=IF(ISBLANK(INDEX(XML!R4C11:R4000C11,0,0)),"""",INDEX(XML!R4C11:R4000C11,0,0))"
.Range("K9" & ":" & "K" & tbl_xml + 8).FormulaArray = "=IF(ISNA(VLOOKUP(INDEX(XML!R4C13:R4000C13,0,0),XML!R4C28:R20C29,2,FALSE)),"""",VLOOKUP(INDEX(XML!R4C13:R4000C13,0,0),XML!R4C28:R20C29,2,FALSE))"
.Range("L9" & ":" & "L" & tbl_xml + 8).FormulaArray = "=IF(XML!R4C16:R4000C16=""refund"",0,IF(XML!R4C16:R4000C16=""void"",0,IF(ISBLANK(INDEX(XML!R4C14:R4000C14,0,0)),"""",INDEX(XML!R4C14:R4000C14,0,0))))"
.Range("M9" & ":" & "M" & tbl_xml + 8).FormulaArray = "=IF(ISBLANK(INDEX(XML!R4C15:R4000C15,0,0)),"""",INDEX(XML!R4C15:R4000C15,0,0))"
.Range("N9" & ":" & "N" & tbl_xml + 8).FormulaArray = "=IF(ISBLANK(INDEX(XML!R4C15:R4000C16,0,0)),"""",INDEX(XML!R4C16:R4000C16,0,0))"
.Range("O9" & ":" & "O" & tbl_xml + 8).FormulaArray = "=IF(ISBLANK(INDEX(XML!R4C2:R4000C2,0,0)),"""",INDEX(XML!R4C2:R4000C2,0,0))"
.Range("P9" & ":" & "P" & tbl_xml + 8).FormulaArray = "=IF(ISBLANK(INDEX(XML!R4C17:R4000C17,0,0)),"""",IF(DATEDIF(R9C4:R4000C4,R9C7:R4000C7,""d"")<=365,0,IF(DATEDIF(R9C4:R4000C4,R9C7:R4000C7,""d"")<=4380,INDEX(XML!R4C17:R4000C17,0,0)*(1-20%),INDEX(XML!R4C17:R4000C17,0,0))))"
.Range("Q9" & ":" & "Q" & tbl_xml + 8).FormulaArray = "=IF(ISBLANK(INDEX(XML!R4C1:R4000C1,0,0)),"""",INDEX(XML!R4C1:R4000C1,0,0))"
' .Range("sb_total").Calculate
.Calculate
'Range(Range("A4").End(xlDown)).Select
'iAreaCount = Selection.Count
' Range("D9:D619").Select
' Range("D619").Activate
' Selection.FormulaArray = _
' "=IF(ISBLANK(INDEX(XML!R[-5]C[2]:R[3991]C[2],0,0)),"""",INDEX(XML!R[-5]C[2]:R[3991]C[2],0,0))"
' Range("E619").Select
End With
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Sub CreatedDBase()
Dim fopen As String
Response = MsgBox("Do you want to start export to FOX now ?" & vbNewLine & _
"ALERT" & vbNewLine & "MM must be Exported at first time!!! ", _
vbYesNo + vbCritical + vbDefaultButton2, _
"Export to FOX")
If Response = vbNo Then Exit Sub
fopen = Application.GetOpenFilename("dBase files (*.dbf),*.dbf")
If fopen <> "False" Then
Set DBConn = CreateObject("ADODB.Connection")
Set dbfrs = CreateObject("ADODB.Recordset")
DBConn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & GetFolderName(fopen) & ";Extended Properties=DBASE IV;")
With dbfrs
.ActiveConnection = DBConn
.CursorType = adOpenStatic
.CursorLocation = 3
.LockType = 3
.Source = "SELECT * FROM" & Chr(32) & GetFileName(fopen) & ";"
.Open
End With
Set rng = ActiveSheet.Range("A9").CurrentRegion
Set rng = rng.Offset(2, 0).Resize(rng.Rows.Count - 3, rng.Columns.Count)
Set xrng = Worksheets("XML").Cells(4, 1).CurrentRegion
Set xrng = xrng.Offset(1, 0).Resize(xrng.Rows.Count - 1, xrng.Columns.Count)
Application.ScreenUpdating = False
With rng
dbfrs.MoveLast
For i = 1 To .Rows.Count
dbfrs.AddNew
For y = 0 To dbfrs.Fields.Count - 1
Select Case y
Case 0
dbfrs.Fields(y).Value = .Cells(i, 17).Value
Case 1
dbfrs.Fields(y).Value = .Cells(i, 15).Value
Case 2
If .Cells(i, 2).Value = Empty Then
dbfrs.Fields(y).Value = Empty
Else
dbfrs.Fields(y).Value = Mid(.Cells(i, 2).Value, 3)
End If
Case 3
dbfrs.Fields(y).Value = Mid(.Cells(i, 3).Value, 1, 30)
Case 4
dbfrs.Fields(y).Value = .Cells(i, 4).Value
Case 5
dbfrs.Fields(y).Value = .Cells(i, 5).Value
Case 6
dbfrs.Fields(y).Value = .Cells(i, 6).Value
Case 7
dbfrs.Fields(y).Value = .Cells(i, 7).Value
Case 8
If xrng.Cells(i, 18).Value <> Empty Then
dbfrs.Fields(y).Value = xrng.Cells(i, 18).Value
Else
dbfrs.Fields(y).Value = 0
End If
Case 9
Set crng = Worksheets("XML").Cells(4, 23).CurrentRegion
Set crng = crng.Offset(1, 0).Resize(crng.Rows.Count - 1, crng.Columns.Count - 1)
Set found = crng.Find(xrng.Cells(i, 12).Value, LookIn:=xlValues)
If Not found Is Nothing Then
dbfrs.Fields(y).Value = found.Offset(columnOffset:=3).Value
End If
Case 10
If UCase(.Cells(i, 10).Value) = "EUR" Then
dbfrs.Fields(y).Value = 978
Else
dbfrs.Fields(y).Value = 840
End If
Case 11
dbfrs.Fields(y).Value = .Cells(i, 11).Value
Case 12
dbfrs.Fields(y).Value = .Cells(i, 12).Value
Case 13
If UCase(.Cells(i, 14).Value) = "ACTIVE" Then
dbfrs.Fields(y).Value = False
Else
dbfrs.Fields(y).Value = True
End If
Case 14
If (VBA.VarType(Application.Evaluate(.Cells(i, 16).Value)) = vbError) Then
dbfrs.Fields(y).Value = 0
Else
dbfrs.Fields(y).Value = .Cells(i, 16).Value
End If
End Select
Next y
Next i
dbfrs.Update
End With
dbfrs.Close
Set rng = Nothing
Set crng = Nothing
Set found = Nothing
Set xrng = Nothing
DBConn.Close
Set dbfrs = Nothing
Set DBConn = Nothing
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile fopen, GetFolderName(fopen) & "\" & _
CStr(Format(CDate(Range("Criteria")), "ddmmyy")) & _
CStr(Format(CDate(Range("CriteriaX")), "ddmmyy")) & _
".dbf", True
Application.ScreenUpdating = True
End If
End Sub
Function GetFileName(nfile As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetFileName = fso.GetFileName(nfile)
End Function
Function GetFolderName(nfile As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetFolderName = fso.GetParentFolderName(nfile)
End Function
