Porównanie zawartości Tabel/Oracle

Poniżej przykładowy kod źródłowy jednego z moich makr. Pobiera dane z jednej bazy danych Oracle, następnie łączy się z drugą bazą i pobiera odpowiednie dane. Następnie porównuje dane przy pomocy odpowiednich formuł. Po obróbce wysyła dane poprzez email do zainteresowanych osób.




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