Dim con As ADODB.Connection
Dim rst As Recordset
Public MySQL As String
Dim fld As Fields
Dim MyRecordCount As Long
Dim MyFieldsCount As Integer
Public MyDataCheck As Boolean
Public MinJobNo As Double
Public MaxJobNo As Double
Public MyToOpenFilePath As String
Public MyLastRow As Integer
Dim MyBudgetValue As Currency
Dim MyActualValue As Currency
Dim MySpendPercentage As Double
Dim MySheet As String
Dim MyRange As String
Dim MyOBArray As Variant
Dim MyBaseJobNumber As String
Dim MyCheckJobNumber As String
Public Sub GetData()
MyDataCheck = False
Application.ScreenUpdating = False
ActiveWorkbook.Unprotect Password:="XXXXXX"
Sheets.Add Count:=1, after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Data" '& Sheets.Count
Application.ScreenUpdating = False
MySheet = "Data"
MyRange = "A2"
Set con = New ADODB.Connection
Set rst = New ADODB.Recordset
If Application.Version >= "12.0" Then
With con
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\SHAREDFOLDER\DATA.accdb"
.Open
End With
Else
With con
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\SHAREDFOLDER\DATA.accdb.accdb"
.Open
End With
End If
With rst
.ActiveConnection = con
.CursorType = adOpenStatic
.CursorLocation = adUseServer
.LockType = adLockOptimistic
.Source = MySQL
.Open
End With
MyRecordCount = rst.RecordCount
If MyRecordCount = 0 Then
With rst
.Close
End With
With con
.Close
End With
Application.ScreenUpdating = True
MyDataCheck = False
MsgBox "No records found for the criteria set." & vbCrLf & vbCrLf & "Data reteval request will be aborted", vbOKOnly + vbExclamation, "Invalid Data Request"
Unload frmWelcome
ThisWorkbook.Close SaveChanges:=False
Exit Sub
ElseIf MyRecordCount >= 3000 Then
With rst
.Close
End With
With conn
.Close
End With
Application.ScreenUpdating = True
MyDataCheck = False
MsgBox "To many records found for the criteria set." & vbCrLf & vbCrLf & "Data reteval request will be aborted", vbOKOnly + vbExclamation, "Invalid Data Request"
Unload frmWelcome
ThisWorkbook.Close SaveChanges:=False
Exit Sub
Else
MyDataCheck = True
MyFieldsCount = rst.Fields.Count
Worksheets(MySheet).Range("A1").Select
For i = 0 To MyFieldsCount - 1
ActiveCell.Value = rst.Fields(i).Name
ActiveCell.Offset(0, 1).Select
Next i
Worksheets(MySheet).Range(MyRange).CopyFromRecordset rst
End If
With rst
.Close
End With
With con
.Close
End With
Set rst = Nothing
Set dbs = Nothing
End Sub
Public Sub FormatSheet()
Cells.Select
With Selection.Font
.Name = "ARIAL"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("A:A").ColumnWidth = 10
Range("A1").Select
ActiveCell.FormulaR1C1 = "XXXXXX" & Chr(10) & "Number"
Columns("B:B").ColumnWidth = 8
Columns("C:C").ColumnWidth = 30
Columns("C:C").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("D:F").ColumnWidth = 7.5
Range("D1").Select
ActiveCell.FormulaR1C1 = "X" & Chr(10) & "XX"
Range("F1").Select
ActiveCell.FormulaR1C1 = "X" & Chr(10) & "XX"
Columns("G:G").ColumnWidth = 13.29
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Rows("1:1").EntireRow.AutoFit
Range("A1").Select
Do While ActiveCell.Value <> ""
ActiveCell.Offset(1, 0).Activate
Loop
MyLastRow = ActiveCell.Row - 1
Range("J2").Select
ActiveCell.FormulaR1C1 = "=RC[-2]-RC[-1]"
Range("J2").Select
Selection.Copy
Range("J3:J" & MyLastRow).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("M2").Select
ActiveCell.FormulaR1C1 = "=RC[-2]-RC[-1]"
Range("M2").Select
Selection.Copy
Range("M3:M" & MyLastRow).Select
ActiveSheet.Paste
Application.CutCopyMode = False
MyLastRow = 0
Range("C2").Select
ActiveWindow.FreezePanes = True
Range("A1:R1").Select
Selection.AutoFilter
Range("A1").Select
End Sub
Public Sub DoCompare()
Dim i As Integer
ThisWorkbook.Worksheets("Data").Activate
ActiveSheet.Unprotect Password:="XXXXXX"
Range("A1").Select
Do While ActiveCell.Value <> ""
ActiveCell.Offset(1, 0).Activate
Loop
MyLastRow = ActiveCell.Row - 1
Range("A2").Select
For i = 2 To MyLastRow
'Compare Columns H and I
MyBudgetValue = Range("H" & i).Value
MyActualValue = Range("I" & i).Value
If MyActualValue > Value Then
Cells(i, 8).Interior.ColorIndex = 38
End If
MyBudgetValue = 0
MyActualValue = 0
'Compare Columns K and L
MyBudgetValue = Range("K" & i).Value
MyActualValue = Range("L" & i).Value
If MyActualValue > Value Then
Cells(i, 11).Interior.ColorIndex = 38
End If
Next i
MyBudgetValue = 0
MyActualValue = 0
'Add Summary Values
Range("H" & MyLastRow + 2).Select
ActiveCell.FormulaR1C1 = "=SUM(R[-" & MyLastRow & "]C:R[-2]C)"
Range("H" & MyLastRow + 2).Select
Selection.Copy
Range("I" & MyLastRow + 2).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("K" & MyLastRow + 2 & ":L" & MyLastRow + 2).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("J" & MyLastRow + 2).Select
ActiveCell.FormulaR1C1 = "=RC[-2]-RC[-1]"
Range("M" & MyLastRow + 2).Select
ActiveCell.FormulaR1C1 = "=RC[-2]-RC[-1]"
Call FormatPrintSetUp
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
ActiveSheet.Protect Password:="XXXXXX", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
Range("A1").Select
End Sub
Public Sub FormatPrintSetUp()
Columns("A:M").Select
ActiveSheet.PageSetup.PrintArea = "$A:$M"
'Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
End With
'Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = "$A:$M"
'Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "&D: Current Production Values"
.CenterFooter = "&""-,Bold"" Confidential"
.RightFooter = "Page &P"
.LeftMargin = Application.InchesToPoints(0.31496062992126)
.RightMargin = Application.InchesToPoints(0.31496062992126)
.TopMargin = Application.InchesToPoints(0.748031496062992)
.BottomMargin = Application.InchesToPoints(0.551181102362205)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
'Application.PrintCommunication = True
Range("A1").Select
End Sub