Compare data tables/Oracle

Some time ago I created this code do compare 2 tables in 2 different databases. This macro in the first step get data from one database, after this get data from second database. In next step data are compare by Excel formulas. The last step send data to some mailboxes.




Public objSession As Object
Public objDataBase As Object
Dim order_start, order_end As String
Const AdminEmail = "xxxx@xxx.pl"
Const DeliverDepolEmail = "xxxx@xxx.pl"
Const DeliverSteinpol = "xxxx@xxx.pl"
Const DeliverInvoices = "xxxx@xxx.pl"

'connection information
Const dbstein = "db1"
Const dbsteincon = "pass1"
Const dbdepol = "db2"
Const dbdepolcon = "pass2"

Private Sub Workbook_Open()
Start
End Sub

Sub Prepare()
Worksheets("DaneS").Range("A:Q").Clear
Worksheets("DaneS2").Range("A:Q").Clear
Worksheets("DaneD").Range("A:Q").Clear
End Sub

Function ConnectToOracleSTEIN() As Boolean
Dim strSQL As String
Dim strResult As String
Dim OraDynaSet As Object
Dim i As Integer
'Clean Data
order_start = "0"
order_end = "0"
Worksheets("DaneS").Range("A:Q").Clear
Worksheets("DaneS").Cells(1, 1) = "Auftrag"
Worksheets("DaneS").Cells(1, 2) = "Auftragsart-Nr."
Worksheets("DaneS").Cells(1, 3) = "Ausgabeart-Nr."
Worksheets("DaneS").Cells(1, 4) = "Drucken"
Worksheets("DaneS").Cells(1, 5) = "Sperrkennzeichen"
Worksheets("DaneS").Cells(1, 6) = "Debitor Nr."
Worksheets("DaneS").Cells(1, 7) = "Debitor Bez."
Worksheets("DaneS").Cells(1, 8) = "Eingangsdatum"
Worksheets("DaneS").Cells(1, 9) = "Erfasungsdatum"
Worksheets("DaneS").Cells(1, 10) = "Lieferdatum"
Worksheets("DaneS").Cells(1, 11) = "Lieferwerk"
Worksheets("DaneS").Cells(1, 12) = "Steinpol Gedruk 160"
Worksheets("DaneS").Cells(1, 13) = "Depol Ausgabeart-Nr."
Worksheets("DaneS").Cells(1, 14) = "Diferenz Ausgabeart-Nr."
Worksheets("DaneS").Cells(1, 15) = "Depol Eingangsdatum"
Worksheets("DaneS").Cells(1, 16) = "Depol Erfasungsdatum"
Worksheets("DaneS").Cells(1, 17) = "Diferenz Erfasungsdatum"

'Create a reference to the OO4O dll
On Error GoTo FrmConnectSTEIN
Set objSession = CreateObject("OracleInProcServer.XOraSession")
'Create a reference to my database
Set objDataBase = objSession.OpenDatabase(dbstein, dbsteincon, 0&)
'select the data
strSQL = "example: select from first database"
'Retrieve the results from Oracle
Set OraDynaSet = objDataBase.DBCreateDynaset(strSQL, 0&)
If OraDynaSet.RecordCount > 0 Then
'There were records retrieved
OraDynaSet.MoveFirst
'Loop the recordset for returned rows
For i = 1 To OraDynaSet.RecordCount
Worksheets("DaneS").Cells(i + 1, 1) = OraDynaSet.Fields(0).Value
If i = 1 Then order_start = OraDynaSet.Fields(0).Value
If i = OraDynaSet.RecordCount Then order_end = OraDynaSet.Fields(0).Value

Worksheets("DaneS").Cells(i + 1, 2) = OraDynaSet.Fields(1).Value
Worksheets("DaneS").Cells(i + 1, 3) = OraDynaSet.Fields(2).Value
Worksheets("DaneS").Cells(i + 1, 4) = OraDynaSet.Fields(3).Value
Worksheets("DaneS").Cells(i + 1, 5) = OraDynaSet.Fields(4).Value
Worksheets("DaneS").Cells(i + 1, 6) = OraDynaSet.Fields(5).Value
Worksheets("DaneS").Cells(i + 1, 7) = OraDynaSet.Fields(6).Value
Worksheets("DaneS").Cells(i + 1, 8) = OraDynaSet.Fields(7).Value
Worksheets("DaneS").Cells(i + 1, 9) = OraDynaSet.Fields(8).Value
Worksheets("DaneS").Cells(i + 1, 10) = OraDynaSet.Fields(9).Value

OraDynaSet.MoveNext

Next i

End If

Set objSession = Nothing
Set objDataBase = Nothing

ConnectToOracleSTEIN = True
FrmConnectSTEIN:
If Err.Number <> 0 Then
SendInformation "", AdminEmail, "Błąd podłączenia"
ConnectToOracleSTEIN = False
Exit Function
End If


End Function

Function ConnectToOracleSTEIN2() As Boolean
Dim strSQL As String
Dim strResult As String
Dim OraDynaSet As Object
Dim i As Integer

'Clean Data
order_start = "0"
order_end = "0"

Worksheets("DaneS2").Range("A:B").Clear
Worksheets("DaneS2").Cells(1, 1) = "Auftrag"
Worksheets("DaneS2").Cells(1, 2) = "Lieferwerk"

On Error GoTo FrmConnectSTEIN2

'Create a reference to the OO4O dll
Set objSession = CreateObject("OracleInProcServer.XOraSession")

'Create a reference to my database
Set objDataBase = objSession.OpenDatabase(dbstein, dbsteincon, 0&)

'select the data
strSQL = "example: select 2 from dbstein, more details ;)"

'Retrieve the results from Oracle
Set OraDynaSet = objDataBase.DBCreateDynaset(strSQL, 0&)
If OraDynaSet.RecordCount > 0 Then

'There were records retrieved
OraDynaSet.MoveFirst
'Loop the recordset for returned rows
For i = 1 To OraDynaSet.RecordCount

Worksheets("DaneS2").Cells(i + 1, 1) = OraDynaSet.Fields(0).Value
Worksheets("DaneS2").Cells(i + 1, 2) = OraDynaSet.Fields(1).Value

OraDynaSet.MoveNext

Next i

End If

Set objSession = Nothing
Set objDataBase = Nothing

ConnectToOracleSTEIN2 = True
FrmConnectSTEIN2:
If Err.Number <> 0 Then
SendInformation "", AdminEmail, "Błąd podłączenia"
ConnectToOracleSTEIN2 = False
Exit Function
End If

End Function

Function ConnectToOracleSTEIN160(inorder As String) As String

Dim strSQL As String

Dim strResult As String

Dim OraDynaSet As Object
Dim i As Integer

On Error GoTo FrmConnectSTEIN160

'Create a reference to the OO4O dll
Set objSession = CreateObject("OracleInProcServer.XOraSession")

'Create a reference to my database
Set objDataBase = objSession.OpenDatabase(dbstein, dbsteincon, 0&)

'select the data
strSQL = "example: select 3 from dbstein, more details ;)"

'Retrieve the results from Oracle
Set OraDynaSet = objDataBase.DBCreateDynaset(strSQL, 0&)
If OraDynaSet.RecordCount > 0 Then

'There were records retrieved
OraDynaSet.MoveFirst
ConnectToOracleSTEIN160 = OraDynaSet.Fields(0).Value

End If

Set objSession = Nothing
Set objDataBase = Nothing

FrmConnectSTEIN160:
If Err.Number <> 0 Then
SendInformation "", AdminEmail, "Błąd podłączenia"
Exit Function
End If

End Function

Function ConnectToOracleDEPOL() As Boolean

Dim strSQL As String

Dim strResult As String

Dim OraDynaSet As Object
Dim i As Integer

'Clean Data

Worksheets("DaneD").Range("A:Q").Clear
Worksheets("DaneD").Cells(1, 1) = "Auftrag"
Worksheets("DaneD").Cells(1, 2) = "Auftragsart-Nr."
Worksheets("DaneD").Cells(1, 3) = "Ausgabeart-Nr."
Worksheets("DaneD").Cells(1, 4) = "Drucken"
Worksheets("DaneD").Cells(1, 5) = "Sperrkennzeichen"
Worksheets("DaneD").Cells(1, 6) = "Eingangsdatum"
Worksheets("DaneD").Cells(1, 7) = "Erfasungsdatum"
Worksheets("DaneD").Cells(1, 8) = "Lieferdatum"

On Error GoTo FrmConnectDEPOL

'Create a reference to the OO4O dll
Set objSession = CreateObject("OracleInProcServer.XOraSession")

'Create a reference to my database
Set objDataBase = objSession.OpenDatabase(dbdepol, dbdepolcon, 0&)

'select the data

If order_start = "" Or order_end = "" Or order_start = "0" Or order_end = "0" Then
order_start = "60000000"
order_end = "69999999"
End If

strSQL = "example select from another database"
'Retrieve the results from Oracle
Set OraDynaSet = objDataBase.DBCreateDynaset(strSQL, 0&)
If OraDynaSet.RecordCount > 0 Then

'There were records retrieved
OraDynaSet.MoveFirst
'Loop the recordset for returned rows
For i = 1 To OraDynaSet.RecordCount

Worksheets("DaneD").Cells(i + 1, 1) = OraDynaSet.Fields(0).Value
Worksheets("DaneD").Cells(i + 1, 2) = OraDynaSet.Fields(1).Value
Worksheets("DaneD").Cells(i + 1, 3) = OraDynaSet.Fields(2).Value
Worksheets("DaneD").Cells(i + 1, 4) = OraDynaSet.Fields(3).Value
Worksheets("DaneD").Cells(i + 1, 5) = OraDynaSet.Fields(4).Value
Worksheets("DaneD").Cells(i + 1, 6) = OraDynaSet.Fields(5).Value
Worksheets("DaneD").Cells(i + 1, 7) = OraDynaSet.Fields(6).Value
Worksheets("DaneD").Cells(i + 1, 8) = OraDynaSet.Fields(7).Value
OraDynaSet.MoveNext
Next i

End If

Set objSession = Nothing
Set objDataBase = Nothing

ConnectToOracleDEPOL = True
FrmConnectDEPOL:
If Err.Number <> 0 Then
SendInformation "", AdminEmail, "Błąd podłączenia"
ConnectToOracleDEPOL = False
Exit Function
End If

End Function

Sub FormatReport()

On Error GoTo FrmReportErr
Range("H:J").Select
Selection.NumberFormat = "d/m/yyyy"
Range("O:P").Select
Selection.NumberFormat = "d/m/yyyy"
Range("Q:Q").Select
Selection.NumberFormat = "0"
Range("L:L").Select
Selection.NumberFormat = "d/m/yyyy hh:mm:ss"

Range("A1:Q1").Select

With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlCellTypeLastCell)).Select
If (Selection.Rows.Count) > 1 Then
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Columns.AutoFit
End If
FrmReportErr:



End Sub

Sub SendInformation(inexcelfile As String, email As String, emailtext As String)
'Send information by email
Const cdoSendUsingPickup = 1
Const cdoSendUsingPort = 2 'Must use this to use Delivery Notification
Const cdoAnonymous = 0
Const cdoBasic = 1 ' clear text
Const cdoNTLM = 2 'NTLM
'Delivery Status Notifications
Const cdoDSNDefault = 0 'None
Const cdoDSNNever = 1 'None
Const cdoDSNFailure = 2 'Failure
Const cdoDSNSuccess = 4 'Success
Const cdoDSNDelay = 8 'Delay
Const cdoDSNSuccessFailOrDelay = 14 'Success, failure or delay

Set objMsg = CreateObject("CDO.Message")
Set objConf = CreateObject("CDO.Configuration")

Set objFlds = objConf.Fields
With objFlds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "xxx.server.pl ;)"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "user"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Update
End With

With objMsg
Set .Configuration = objConf
.To = email
.From = "stg_06@steinpol-ok.com.pl"
.Subject = "Report Exchange"
.TextBody = emailtext
'use .HTMLBody to send HTML email.
If Len(inexcelfile) > 0 Then
.Addattachment inexcelfile
End If
.Fields("urn:schemas:mailheader:disposition-notification-to") = AdminEmail
.DSNOptions = cdoDSNSuccessFailOrDelay
.Fields.Update
.Send
End With

End Sub
Sub PrepareReport()
Dim i As Integer
Dim s, s1, s2, tmp As String
Worksheets("DaneS").Range("A1").Activate
i = 1
Do
i = i + 1
If Worksheets("DaneS").Cells(i, 1) = "" Then Exit Do


'Lieferwerk
tmp = "MATCH(A" + LTrim(RTrim(Str(i))) + ",DaneS2!A:A,0)"
s = "=IF(ISERROR(" + tmp + "),"" "",""Lieferwerk Fehler"")"
s1 = "K" + RTrim(LTrim(Str(i)))
Worksheets("DaneS").Range(s1).Formula = s

'Print Time Steinpol (160)
If Worksheets("DaneS").Range("C" + RTrim(LTrim(Str(i)))).Value = "160" Then
Worksheets("DaneS").Range("L" + RTrim(LTrim(Str(i)))).Value = ConnectToOracleSTEIN160(Worksheets("DaneS").Range("A" + RTrim(LTrim(Str(i)))).Value)
End If



'Ausgabeart-Nr.
tmp = "VLOOKUP(A" + LTrim(RTrim(Str(i))) + ",DaneD!$A:$G,3,0)"
s = "=IF(ISERROR(" + tmp + "),""Null""," + tmp + ")"
s1 = "M" + RTrim(LTrim(Str(i)))
Worksheets("DaneS").Range(s1).Formula = s
s2 = "N" + RTrim(LTrim(Str(i)))
tmp = "C" + RTrim(LTrim(Str(i))) + "-M" + RTrim(LTrim(Str(i)))
Worksheets("DaneS").Range(s2).Formula = "=IF(ISERROR(" + tmp + "),""Null""," + tmp + ")"

'Eingangsdatum
tmp = "VLOOKUP(A" + LTrim(RTrim(Str(i))) + ",DaneD!$A:$G,6,0)"
s = "=IF(ISERROR(" + tmp + "),""Null""," + tmp + ")"
s1 = "O" + RTrim(LTrim(Str(i)))
Worksheets("DaneS").Range(s1).Formula = s


'Erfasungsdatum

s = "=if(iserror(VLOOKUP(A" + LTrim(RTrim(Str(i))) + ",DaneD!$A:$G,7,0)),""Null"",VLOOKUP(A" + LTrim(RTrim(Str(i))) + ",DaneD!$A:$G,7,0))"
s1 = "P" + RTrim(LTrim(Str(i)))
Worksheets("DaneS").Range(s1).Formula = s
s2 = "Q" + RTrim(LTrim(Str(i)))
s = "I" + RTrim(LTrim(Str(i))) + "-P" + RTrim(LTrim(Str(i)))
Worksheets("DaneS").Range(s2).Formula = "=if(iserror(" + s + "),""Null""," + s + ")"

Loop

End Sub

Sub PrepareReportToSend(email As String, emailtext As String)
Dim cr As String

Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
If Selection.Rows.Count > 1 Then
Selection.Copy

Dim WrkSend As Workbook
Set WrkSend = Workbooks.Add
With WrkSend
.Title = "Auftrag Steinpol Depol"
.Subject = "Auftrag Steinpol Depol"
.ActiveSheet.Paste
Range("A:Q").Select
FormatReport

.SaveAs filename:="Auftrag.xls"
.Close (False)
SendInformation CurDir + "\Auftrag.xls", email, emailtext
On Error GoTo DeleteErr
Kill "Auftrag.xls"
Exit Sub
End With
End If
DeleteErr:

End Sub

Sub Start()
Prepare
If (ConnectToOracleSTEIN And ConnectToOracleDEPOL And ConnectToOracleSTEIN2) Then

PrepareReport

If WeekDay(Date, vbMonday) >= 1 And WeekDay(Date, vbMonday) <= 5 Then
Workbooks("STEIN-DEPOL.xls").Activate
Range("A:Q").Select
Selection.AutoFilter
Selection.AutoFilter Field:=13, Criteria1:="160"
PrepareReportToSend DeliverDepolEmail, ";) "

Workbooks("STEIN-DEPOL.xls").Activate
Range("A:Q").Select
Selection.AutoFilter
Selection.AutoFilter Field:=13, Criteria1:="Null"
Selection.AutoFilter Field:=3, Criteria1:="160"
PrepareReportToSend AdminEmail, ";)"
End If

If WeekDay(Date, vbMonday) = 1 Or WeekDay(Date, vbMonday) <= 3 Or WeekDay(Date, vbMonday) <= 5 Then
Workbooks("STEIN-DEPOL.xls").Activate
Range("A:Q").Select
Selection.AutoFilter
Selection.AutoFilter Field:=3, Criteria1:="160"
Selection.AutoFilter Field:=4, Criteria1:="1"
PrepareReportToSend DeliverSteinpol, ";)"
End If

If WeekDay(Date, vbMonday) = 5 Then
Workbooks("STEIN-DEPOL.xls").Activate
Range("A:Q").Select
Selection.AutoFilter
Selection.AutoFilter Field:=14, Criteria1:="=-210", Operator:=xlOr, _
Criteria2:="=-200"
PrepareReportToSend DeliverInvoices, ";)"
End If
End If

ActiveWorkbook.Close (False)
Application.Quit

End Sub