Code:
Option Explicit
Dim NumParts
Sub DKRateFromExtract()
Dim TXT As Object
Dim MyAccess As Object
Dim ol As Object
Dim olItem As Object
Dim Row, ColPrices, NumParts, x, MyCol, RoundMe, SumRow, SumCol, RealSumRow, LastRow As Long
Dim MyBook As Workbook
Dim MySheet, CurSheet, CurrenciesSheet, SumSheet As Worksheet
Dim MyDb, qDef As Object
Dim RS, RS2, RS3, RS4, CN As Object
Dim MySQL, qName, WhichComp As String
Dim MyArray(), MyArray2(), TotalRates As Double
Dim MyDate As Date
'Turn off annoying applications and anything that might slow down the macro
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Set my excel objects for future reference
Set MyBook = ActiveWorkbook
Set MySheet = ActiveSheet
'Remove any sheets that aren't necessary
For x = Sheets.Count To 1 Step -1
If Sheets(x).Name <> "Competitor Products" Then
Sheets(x).Delete
End If
Next
Set CN = CreateObject("ADODB.Connection")
CN.Open "Provider=Microsoft.ACE.OLEDB.15.0;Data Source=\\filesvr1\pricmgmt\Global Currency Support\Currency Rate Reviews\ReviewSupportFiles\DKRateHelper.accdb"
Set RS3 = CN.Execute("qryDeletetblDKDataTemp")
Set RS3 = Nothing
Set CN = Nothing
'Create a .txt object for import to the database
Set TXT = CreateObject("Scripting.FileSystemObject").CreateTextFile(Environ("userprofile") & "\Desktop\import.txt", True)
TXT.WriteLine "Domain|DKSupplierName|DKPN|MfgPN|QB1|PB1|QB2|PB2|QB3|PB3|QB4|PB4|QB5|PB5|QB6|PB6|QB7|PB7|QB8|PB8|QB9|PB9|ATS"
'Populate the .txt object with the PNs and resales
For Row = 2 To MySheet.Cells(MySheet.Rows.Count, 1).End(xlUp).Row
If MySheet.Cells(Row, 17) <> "" And Not MySheet.Cells(Row, 4) = "" Then
TXT.WriteLine MySheet.Cells(Row, 1) & "|" & MySheet.Cells(Row, 4) & "|" & MySheet.Cells(Row, 2) & "|" & MySheet.Cells(Row, 3) & "|" & MySheet.Cells(Row, 17) & "|" & MySheet.Cells(Row, 18) & "|" & MySheet.Cells(Row, 19) & "|" & MySheet.Cells(Row, 20) & "|" & MySheet.Cells(Row, 21) & "|" & MySheet.Cells(Row, 22) & "|" & MySheet.Cells(Row, 23) & "|" & MySheet.Cells(Row, 24) & "|" & MySheet.Cells(Row, 25) & "|" & MySheet.Cells(Row, 26) & "|" & MySheet.Cells(Row, 27) & "|" & MySheet.Cells(Row, 28) & "|" & MySheet.Cells(Row, 29) & "|" & MySheet.Cells(Row, 30) & "|" & MySheet.Cells(Row, 31) & "|" & MySheet.Cells(Row, 32) & "|" & MySheet.Cells(Row, 33) & "|" & MySheet.Cells(Row, 34) & "|" & MySheet.Cells(Row, 8)
End If
Next
'Close the .txt object and remove the object
TXT.Close
Set TXT = Nothing
'Create the access object, import the .txt file and delete the .txt file
Set MyAccess = CreateObject("Access.Application")
MyAccess.OpenCurrentDatabase "\\filesvr1\pricmgmt\Global Currency Support\Currency Rate Reviews\ReviewSupportFiles\DKRateHelper.accdb"
'MyAccess.DoCmd.OpenQuery "qryDeletetblDKDataTemp" '"DELETE tblDKDataTemp.* FROM tblDKDataTemp;"
MyAccess.DoCmd.TransferText acImportDelim, "Import Specification", "tblDKDataTemp", Environ("userprofile") & "\Desktop\Import.txt", True, ""
Set MyDb = MyAccess.CurrentDb
Kill Environ("userprofile") & "\Desktop\import.txt"
'Connect to the database object so we can run local queries and create recordsets which I wasn't able to do through the Access object
Set CN = CreateObject("ADODB.Connection")
CN.Open "Provider=Microsoft.ACE.OLEDB.15.0;Data Source=\\filesvr1\pricmgmt\Global Currency Support\Currency Rate Reviews\ReviewSupportFiles\DKRateHelper.accdb"
'Find the last entry into the Currency Review Database so it can be used for data later
MySQL = "SELECT Last(WeekMondayDate) as MyDate " & _
"FROM tblForEx;"
Set RS3 = CN.Execute(MySQL)
MyDate = RS3!MyDate
Set RS = Nothing
MyBook.Sheets.Add.Name = "CurrenciesAndDeviantSuppliers"
Set CurrenciesSheet = ActiveSheet
CurrenciesSheet.Cells(1, 1) = "Digikey's Primary Conversion Rates from USD as of " & Date & " and Suppliers Not Following Them"
With CurrenciesSheet.Cells(1, 1)
.Font.Bold = True
.Font.Size = 24
.HorizontalAlignment = xlLeft
End With
CurrenciesSheet.Columns("A:A").ColumnWidth = 30
MyBook.Sheets.Add.Name = "Summary"
Set SumSheet = ActiveSheet
SumSheet.Cells(1, 1) = "Summary of Digikey's Rates By Currency as of " & Date
With SumSheet.Cells(1, 1)
.Font.Bold = True
.Font.Size = 18
.HorizontalAlignment = xlLeft
End With
SumSheet.Cells(4, 1) = "Currency Code"
SumSheet.Cells(4, 2) = "Currency Name"
SumSheet.Cells(4, 3) = "Mouser's Sales Rate"
SumSheet.Cells(4, 4) = "Sales Rate Change Date"
SumSheet.Cells(4, 5) = "Mouser's Finance Rate"
SumSheet.Cells(4, 6) = "Foreign Exchange Rate"
SumSheet.Cells(4, 7) = "DK's Mode Rate"
SumSheet.Cells(4, 8) = "DK's Median Rate"
SumSheet.Cells(4, 9) = "DK's Mean Rate"
SumSheet.Cells(4, 10) = "DK's Rate Range"
SumSheet.Cells(4, 11) = "DK's Standard Deviation"
SumSheet.Cells(4, 12) = "# of Suppliers Not Following Standard Rates"
Columns("A:A").ColumnWidth = 9
Columns("B:B").ColumnWidth = 18
Columns("C:C").ColumnWidth = 10
Columns("D:E").ColumnWidth = 13
Columns("F:F").ColumnWidth = 25
Columns("G:G").ColumnWidth = 11
Columns("H:H").ColumnWidth = 13
Columns("I:I").ColumnWidth = 11
Columns("J:J").ColumnWidth = 17
Columns("K:K").ColumnWidth = 14
Columns("L:L").ColumnWidth = 25
With Range(SumSheet.Cells(4, 1), SumSheet.Cells(4, 12))
.Font.Bold = True
.Font.Size = 12
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Interior.ThemeColor = xlThemeColorDark1
.Interior.TintAndShade = -0.149998474074526
End With
SumSheet.Rows("4:4").RowHeight = 36
RealSumRow = 5
'Find the domains that are going to be reviewed by this process
MySQL = "SELECT CompetitorDomainForCurrnecy, CompetitorForCurrency as Cur, CurrencyName " & _
"FROM tblCompetitorCurrencies LEFT JOIN tblCurrencies ON tblCompetitorCurrencies.CompetitorForCurrency = tblCurrencies.ForeignCurrencyCode " & _
"WHERE CompetitorDomainForCurrnecy Is Not Null AND CompetitorDomainForCurrnecy <> ""www.digikey.com"" AND CompetitorName = ""Digikey"";"
Set RS = CN.Execute(MySQL)
'Start going through domain by domain to process the data
SumRow = 4
If Not RS.EOF And Not RS.BOF Then
Do Until RS.EOF
SumCol = 4
'If RS!Cur = "DKK" Or RS!Cur = "GBP" Or RS!Cur = "NOK" Or RS!Cur = "SEK" Then Stop
'Create a query that will separate out the resales for the domain we're currently reviewing
MySQL = "SELECT Domain, DKPN, MfgPN, QB1, PB1, QB2, PB2, QB3, PB3, QB4, PB4, QB5, PB5, QB6, PB6, QB7, PB7, QB8, PB8, QB9, PB9 " & _
"FROM tblDKDataTemp " & _
"WHERE Domain=""" & RS!CompetitorDomainForCurrnecy & """;"
qName = "qryDKin" & RS!Cur
On Error Resume Next
MyDb.querydefs.Delete qName
On Error GoTo 0
Set qDef = MyDb.CreateQueryDef(qName, MySQL)
'Set up the query to get the data for buth USD and the domain we're looking at
MySQL = "SELECT qryDKinUSD.DKPN, qryDKinUSD.PB1 AS USD1, " & qName & ".PB1, qryDKinUSD.PB2 AS USD2, " & qName & ".PB2, qryDKinUSD.PB3 AS USD3, " & qName & ".PB3, qryDKinUSD.PB4 AS USD4, " & qName & ".PB4, qryDKinUSD.PB5 AS USD5, " & qName & ".PB5, qryDKinUSD.PB6 AS USD6, " & qName & ".PB6, qryDKinUSD.PB7 AS USD7, " & qName & ".PB7, qryDKinUSD.PB8 AS USD8, " & qName & ".PB8, qryDKinUSD.PB9 AS USD9, " & qName & ".PB9, tblCompParts.SupplierNmbr, tblCompParts.SupplierName " & _
"FROM tblCompParts INNER JOIN (qryDKinUSD INNER JOIN " & qName & " ON qryDKinUSD.DKPN = " & qName & ".DKPN) ON tblCompParts.MfgPartNmbr = qryDKinUSD.MfgPN;"
On Error GoTo MyWaiting
Set RS2 = CN.Execute(MySQL)
On Error GoTo 0
MyBook.Sheets.Add.Name = RS!Cur
'Start setting up an Excel worksheet for the current domains rates from USD to the foreign currency
Set CurSheet = ActiveSheet
CurSheet.Cells(1, 1) = "Summary of Digikey Rates for " & RS!CurrencyName & " as of " & Date
With CurSheet.Cells(1, 1)
.Font.Bold = True
.Font.Size = 18
.HorizontalAlignment = xlLeft
End With
CurSheet.Cells(3, 1) = "Mouser's Rate"
CurSheet.Cells(4, 1) = "Sale's rate Change Date"
CurSheet.Cells(5, 1) = "Finance Rate"
CurSheet.Cells(6, 1) = "DK's Mode Rate"
CurSheet.Cells(7, 1) = "DK's Median Rate"
CurSheet.Cells(8, 1) = "DK's Mean Rate"
CurSheet.Cells(9, 1) = "DK's Maximum Rate"
CurSheet.Cells(10, 1) = "DK's Minimum Rate"
CurSheet.Cells(11, 1) = "DK's Standard Deviation of Rates"
CurSheet.Cells(12, 1) = "Forex Rate for " & Date
CurSheet.Columns("A:A").ColumnWidth = 30
With Range(CurSheet.Cells(3, 1), CurSheet.Cells(13, 1))
.Font.Bold = True
.HorizontalAlignment = xlLeft
End With
'Find the data from the Currency Review Database
MySQL = "SELECT ForExRate, ForExRate2, BaseCUR, ForCUR, LastSalesRateChangeDate, SalesRate, FinanceRate " & _
"FROM tblForEx " & _
"WHERE ForCUR = """ & RS!Cur & """ AND WeekMondayDate = #" & MyDate & "#;"
Set RS3 = CN.Execute(MySQL)
'Start inserting data for the domain as a whole
SumSheet.Cells(RealSumRow, 1) = RS!Cur
SumSheet.Cells(RealSumRow, 2) = RS!CurrencyName
CurSheet.Cells(3, 2) = RS3!SalesRate
SumSheet.Cells(RealSumRow, 3) = RS3!SalesRate
CurSheet.Cells(4, 2) = RS3!LastSalesRateChangeDate
SumSheet.Cells(RealSumRow, 4) = RS3!LastSalesRateChangeDate
CurSheet.Cells(4, 2).NumberFormat = "m/d/yyyy"
SumSheet.Cells(RealSumRow, 4).NumberFormat = "m/d/yyyy"
CurSheet.Cells(5, 2) = RS3!FinanceRate
SumSheet.Cells(RealSumRow, 5) = RS3!FinanceRate
CurSheet.Cells(12, 2) = RS3!ForExRate
SumSheet.Cells(RealSumRow, 6) = "Forex " & RS3!BaseCur & " to " & RS3!ForCUR & ": " & RS3!ForExRate
CurSheet.Cells(12, 1) = "Forex " & RS3!BaseCur & " to " & RS3!ForCUR
If RS3!BaseCur <> "USD" Then
CurSheet.Cells(13, 1) = "Forex USD to " & RS3!ForCUR
CurSheet.Cells(13, 2) = RS3!ForExRate2
End If
'Put the rate data into an Array so that we can find some statistics off of it.
ReDim MyArray(5000)
NumParts = 1
If Not RS2.EOF And Not RS2.BOF Then
Do Until RS2.EOF
TotalRates = 0
ColPrices = 0
If Not IsNull(RS2!USD1) And Not IsNull(RS2!PB1) Then
TotalRates = RS2!PB1 / RS2!USD1 + TotalRates
ColPrices = ColPrices + 1
End If
If Not IsNull(RS2!USD2) And Not IsNull(RS2!PB2) Then
TotalRates = RS2!PB2 / RS2!USD2 + TotalRates
ColPrices = ColPrices + 1
End If
If Not IsNull(RS2!USD3) And Not IsNull(RS2!PB3) Then
TotalRates = RS2!PB3 / RS2!USD3 + TotalRates
ColPrices = ColPrices + 1
End If
If Not IsNull(RS2!USD4) And Not IsNull(RS2!PB4) Then
TotalRates = RS2!PB4 / RS2!USD4 + TotalRates
ColPrices = ColPrices + 1
End If
If Not IsNull(RS2!USD5) And Not IsNull(RS2!PB5) Then
TotalRates = RS2!PB5 / RS2!USD5 + TotalRates
ColPrices = ColPrices + 1
End If
If Not IsNull(RS2!USD6) And Not IsNull(RS2!PB6) Then
TotalRates = RS2!PB6 / RS2!USD6 + TotalRates
ColPrices = ColPrices + 1
End If
If Not IsNull(RS2!USD7) And Not IsNull(RS2!PB7) Then
TotalRates = RS2!PB7 / RS2!USD7 + TotalRates
ColPrices = ColPrices + 1
End If
If Not IsNull(RS2!USD8) And Not IsNull(RS2!PB8) Then
TotalRates = RS2!PB8 / RS2!USD8 + TotalRates
ColPrices = ColPrices + 1
End If
If Not IsNull(RS2!USD9) And Not IsNull(RS2!PB9) Then
TotalRates = RS2!PB9 / RS2!USD9 + TotalRates
ColPrices = ColPrices + 1
End If
If TotalRates / ColPrices < 1 Then
RoundMe = 5
ElseIf TotalRates / ColPrices < 5 Then
RoundMe = 4
ElseIf TotalRates / ColPrices < 10 Then
RoundMe = 3
Else
RoundMe = 2
End If
MyArray(NumParts) = Round(TotalRates / ColPrices, RoundMe)
NumParts = NumParts + 1
RS2.MoveNext
Loop
End If
ReDim MyArray2(NumParts - 1)
'Mode won't work correctly if anything in the array is empty, so we create a more specific array that only allows the number of entries that we will have.
For x = 1 To NumParts - 1
MyArray2(x) = MyArray(x)
'Cells(14 + x, 1) = MyArray(x)
Next
'Get the statistics on the domain level
CurSheet.Cells(6, 2) = Application.Mode(MyArray2)
SumSheet.Cells(RealSumRow, 7) = CurSheet.Cells(6, 2)
CurSheet.Cells(7, 2) = Application.Median(MyArray2)
SumSheet.Cells(RealSumRow, 8) = CurSheet.Cells(7, 2)
CurSheet.Cells(8, 2) = Round(Application.Average(MyArray2), RoundMe)
SumSheet.Cells(RealSumRow, 9) = CurSheet.Cells(8, 2)
CurSheet.Cells(9, 2) = Application.Max(MyArray2)
CurSheet.Cells(10, 2) = Application.Min(MyArray2)
SumSheet.Cells(RealSumRow, 10) = CurSheet.Cells(10, 2) & " to " & CurSheet.Cells(9, 2)
CurSheet.Cells(11, 2) = Round(Application.StDev(MyArray2), 6)
SumSheet.Cells(RealSumRow, 11) = CurSheet.Cells(11, 2)
With CurrenciesSheet.Cells(SumRow, 1)
.Value = RS!CurrencyName
.Font.Bold = True
.Font.Size = 18
End With
Range(CurrenciesSheet.Cells(SumRow + 1, 1), CurrenciesSheet.Cells(SumRow + 11, 2)).Value = Range(CurSheet.Cells(3, 1), CurSheet.Cells(13, 2)).Value
With Range(CurrenciesSheet.Cells(SumRow + 1, 1), CurrenciesSheet.Cells(SumRow + 11, 1))
.Font.Bold = True
.HorizontalAlignment = xlLeft
End With
CurrenciesSheet.Cells(SumRow + 2, 2).NumberFormat = "mm/dd/yyyy"
'Now get the data supplier by supplier
'MySQL = "SELECT SupplierName, SupplierNmbr " & _
"FROM tblCompParts " & _
"GROUP BY SupplierName, SupplierNmbr;"
MySQL = "SELECT DKSupplierName " & _
"FROM qryDKSUpplierNames;"
' "WHERE Domain = ""www.digikey.com"" "
' "GROUP BY DKSupplierName;"
Set RS3 = CN.Execute(MySQL)
If Not RS3.EOF And Not RS3.BOF Then
MyCol = 4
Do Until RS3.EOF
'Find the data for the current supplier we will be looking at
MySQL = "SELECT qryDKinUSD.DKPN, qryDKinUSD.PB1 AS USD1, " & qName & ".PB1, qryDKinUSD.PB2 AS USD2, " & qName & ".PB2, qryDKinUSD.PB3 AS USD3, " & qName & ".PB3, qryDKinUSD.PB4 AS USD4, " & qName & ".PB4, qryDKinUSD.PB5 AS USD5, " & qName & ".PB5, qryDKinUSD.PB6 AS USD6, " & qName & ".PB6, qryDKinUSD.PB7 AS USD7, " & qName & ".PB7, qryDKinUSD.PB8 AS USD8, " & qName & ".PB8, qryDKinUSD.PB9 AS USD9, " & qName & ".PB9, tblCompParts.SupplierNmbr, tblCompParts.SupplierName " & _
"FROM tblCompParts INNER JOIN (qryDKinUSD INNER JOIN " & qName & " ON qryDKinUSD.DKPN = " & qName & ".DKPN) ON tblCompParts.MfgPartNmbr = qryDKinUSD.MfgPN " & _
"WHERE DKSupplierName = """ & RS3!DKSupplierName & """;"
Set RS2 = CN.Execute(MySQL)
ReDim MyArray(5000)
NumParts = 1
If Not RS2.EOF And Not RS2.BOF Then
Do Until RS2.EOF
TotalRates = 0
ColPrices = 0
If Not IsNull(RS2!USD1) And Not IsNull(RS2!PB1) Then
TotalRates = RS2!PB1 / RS2!USD1 + TotalRates
ColPrices = ColPrices + 1
End If
If Not IsNull(RS2!USD2) And Not IsNull(RS2!PB2) Then
TotalRates = RS2!PB2 / RS2!USD2 + TotalRates
ColPrices = ColPrices + 1
End If
If Not IsNull(RS2!USD3) And Not IsNull(RS2!PB3) Then
TotalRates = RS2!PB3 / RS2!USD3 + TotalRates
ColPrices = ColPrices + 1
End If
If Not IsNull(RS2!USD4) And Not IsNull(RS2!PB4) Then
TotalRates = RS2!PB4 / RS2!USD4 + TotalRates
ColPrices = ColPrices + 1
End If
If Not IsNull(RS2!USD5) And Not IsNull(RS2!PB5) Then
TotalRates = RS2!PB5 / RS2!USD5 + TotalRates
ColPrices = ColPrices + 1
End If
If Not IsNull(RS2!USD6) And Not IsNull(RS2!PB6) Then
TotalRates = RS2!PB6 / RS2!USD6 + TotalRates
ColPrices = ColPrices + 1
End If
If Not IsNull(RS2!USD7) And Not IsNull(RS2!PB7) Then
TotalRates = RS2!PB7 / RS2!USD7 + TotalRates
ColPrices = ColPrices + 1
End If
If Not IsNull(RS2!USD8) And Not IsNull(RS2!PB8) Then
TotalRates = RS2!PB8 / RS2!USD8 + TotalRates
ColPrices = ColPrices + 1
End If
If Not IsNull(RS2!USD9) And Not IsNull(RS2!PB9) Then
TotalRates = RS2!PB9 / RS2!USD9 + TotalRates
ColPrices = ColPrices + 1
End If
If TotalRates / ColPrices < 1 Then
RoundMe = 5
ElseIf TotalRates / ColPrices < 5 Then
RoundMe = 4
ElseIf TotalRates / ColPrices < 10 Then
RoundMe = 3
Else
RoundMe = 2
End If
MyArray(NumParts) = Round(TotalRates / ColPrices, RoundMe)
NumParts = NumParts + 1
RS2.MoveNext
Loop
End If
If NumParts > 1 Then
ReDim MyArray2(NumParts - 1)
'Mode won't work correctly if anything in the array is empty, so we create a more specific array that only allows the number of entries that we will have.
For x = 1 To NumParts - 1
MyArray2(x) = MyArray(x)
'Cells(14 + x, MyCol) = MyArray(x)
Next
CurSheet.Cells(2, MyCol) = RS3!DKSupplierName
'###############Need to add the ERs if applicable
CurSheet.Cells(6, MyCol) = Application.Mode(MyArray2)
CurSheet.Cells(7, MyCol) = Application.Median(MyArray2)
If IsError(CurSheet.Cells(6, MyCol)) Then ' = "Error 2042" Then '"#N/A" Then
CurSheet.Cells(6, MyCol) = CurSheet.Cells(7, MyCol)
End If
CurSheet.Cells(8, MyCol) = Round(Application.Average(MyArray2), RoundMe)
CurSheet.Cells(9, MyCol) = Application.Max(MyArray2)
CurSheet.Cells(10, MyCol) = Application.Min(MyArray2)
If NumParts > 2 Then
CurSheet.Cells(11, MyCol) = Round(Application.StDev(MyArray2), 6)
End If
Else
CurSheet.Cells(2, MyCol) = RS3!DKSupplierName
CurSheet.Cells(6, MyCol) = "No Competitor Data Received For Review"
End If
If Deviant(Sheets(CurSheet.Name), CLng(MyCol), CLng(SumRow), CLng(SumCol), Sheets(CurrenciesSheet.Name)) = True Then
Range(CurrenciesSheet.Cells(SumRow, SumCol), CurrenciesSheet.Cells(SumRow + 9, SumCol)).Value = Range(CurSheet.Cells(2, MyCol), CurSheet.Cells(11, MyCol)).Value
SumCol = SumCol + 1
End If
MyCol = MyCol + 1
RS3.MoveNext
Loop
End If
SumSheet.Cells(RealSumRow, 12) = CurrenciesSheet.Cells(SumRow, Columns.Count).End(xlToLeft).Column - 3
If SumSheet.Cells(RealSumRow, 12) < 0 Then SumSheet.Cells(RealSumRow, 12) = 0
MyDb.querydefs.Delete qName
CurSheet.Visible = xlSheetHidden
'Stop
SumRow = SumRow + 13
RealSumRow = RealSumRow + 1
RS.MoveNext
Loop
End If
'Now load the data into the database.
LastRow = SumSheet.Cells(Rows.Count, 1).End(xlUp).Row
For Row = 5 To LastRow
MySQL = "SELECT CompToCompare1, CompToCompare2, CompToCompare3 " & _
"FROM tblCurrencies " & _
"WHERE CurrencyCode = """ & SumSheet.Cells(Row, 1) & """;"
Set RS = CN.Execute(MySQL)
If RS!CompToCompare1 = "DigiKey" Then
WhichComp = 1
ElseIf RS!CompToCompare2 = "DigiKey" Then
WhichComp = 2
ElseIf RS!CompToCompare3 = "DigiKey" Then
WhichComp = 3
End If
MySQL = "UPDATE tblForEx SET tblForEx.Comp" & WhichComp & "Rate = " & SumSheet.Cells(Row, 7) & " " & _
"WHERE WeekMondayDate=#" & MyDate & "# AND ForCUR=""" & SumSheet.Cells(Row, 1) & """;"
Set RS = CN.Execute(MySQL)
Next
With Range(SumSheet.Cells(4, 1), SumSheet.Cells(LastRow, 12))
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
With Range(SumSheet.Cells(4, 1), SumSheet.Cells(4, 12))
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlMedium
.Interior.ThemeColor = xlThemeColorDark1
.Interior.TintAndShade = -0.249977111117893
End With
SumSheet.Activate
MySheet.Visible = xlSheetHidden
'Now prepare the email to send to Nick and others.
'With CreateObject("Outlook.Application").CreateItem(0)
' MySQL = "SELECT "
'
'
'
'End With
Set RS3 = CN.Execute("qryDeletetblDKDataTemp")
CN.Close
Set CN = Nothing
Set RS = Nothing
Set RS2 = Nothing
Set RS3 = Nothing
MyAccess.Quit
Set MyAccess = Nothing
MyBook.SaveAs "\\Filesvr1\pricmgmt\Global Currency Support\Currency Rate Reviews\CompetitorReviews\DigikeyRateReview_" & Format(Date, "MMDDYYYY") & ".xlsx"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
MyWaiting:
Err.Clear
Application.Wait (Now + #12:00:01 AM#)
Resume
End Sub
Function Deviant(CurSheet As Worksheet, MyCol As Long, SumRow As Long, SumCol As Long, CurrenciesSheet As Worksheet) As Boolean
Deviant = False
If CurSheet.Cells(6, MyCol) <> "" And CurSheet.Cells(6, MyCol) <> "No Competitor Data Received For Review" And (CurSheet.Cells(6, MyCol) > CurSheet.Cells(6, 2) * 1.01 Or CurSheet.Cells(6, MyCol) < CurSheet.Cells(6, 2) * 0.99) Then
Deviant = True
CurSheet.Cells(6, MyCol).Interior.Color = 65535
CurrenciesSheet.Cells(SumRow + 4, SumCol).Interior.Color = 65535
End If
If CurSheet.Cells(7, MyCol) <> "" And (CurSheet.Cells(7, MyCol) > CurSheet.Cells(7, 2) * 1.01 Or CurSheet.Cells(7, MyCol) < CurSheet.Cells(7, 2) * 0.99) Then
Deviant = True
CurSheet.Cells(7, MyCol).Interior.Color = 65535
CurrenciesSheet.Cells(SumRow + 5, SumCol).Interior.Color = 65535
End If
If CurSheet.Cells(6, MyCol) = "No Competitor Data Received For Review" Then
'Deviant = True
'CurrenciesSheet.Cells(SumRow + 4, SumCol).Interior.Color = 65535
Else
If CurSheet.Cells(8, MyCol) <> "" And (CurSheet.Cells(8, MyCol) > CurSheet.Cells(6, MyCol) * 1.01 Or CurSheet.Cells(8, MyCol) < CurSheet.Cells(6, MyCol) * 0.99) Then
Deviant = True
CurSheet.Cells(8, MyCol).Interior.Color = 65535
CurrenciesSheet.Cells(SumRow + 6, SumCol).Interior.Color = 65535
End If
' If CurSheet.Cells(9, MyCol) <> "" And (CurSheet.Cells(9, MyCol) > CurSheet.Cells(6, MyCol) * 1.01 Or CurSheet.Cells(9, MyCol) < CurSheet.Cells(6, MyCol) * 0.99) Then
' Deviant = True
' CurSheet.Cells(9, MyCol).Interior.Color = 65535
' End If
' If CurSheet.Cells(10, MyCol) <> "" And (CurSheet.Cells(10, MyCol) > CurSheet.Cells(6, MyCol) * 1.01 Or CurSheet.Cells(10, MyCol) < CurSheet.Cells(6, MyCol) * 0.99) Then
' Deviant = True
' CurSheet.Cells(10, MyCol).Interior.Color = 65535
' End If
If CurSheet.Cells(11, MyCol) <> "" And (CurSheet.Cells(11, MyCol) > CurSheet.Cells(6, MyCol) * 0.1) Then
Deviant = True
CurSheet.Cells(11, MyCol).Interior.Color = 65535
CurrenciesSheet.Cells(SumRow + 9, SumCol).Interior.Color = 65535
End If
End If
End Function
Sub GetDKPartsForBots()
Dim CN, RS, IE As Object
Dim MyBook As Workbook
Dim MySheet As Worksheet
Dim MyFileName As String
Set CN = CreateObject("ADODB.Connection")
CN.Open "Provider=Microsoft.ACE.OLEDB.15.0;Data Source=\\filesvr1\pricmgmt\Global Currency Support\Currency Rate Reviews\ReviewSupportFiles\DKRateHelper.accdb"
Set RS = CN.Execute("qryDKPartsForBots")
Set MyBook = Workbooks.Add
If ActiveSheet.Name <> "Sheet1" Then
Sheets.Add.Name = "Sheet1"
End If
Cells(1, 1) = "Domain"
Cells(1, 2) = "MfrAsKnownByMouser"
Cells(1, 3) = "MfrAsKnownByOther"
Cells(1, 4) = "MfrPartNumber"
Cells(1, 5) = "NextRunDate"
Cells(1, 6) = "Priority"
Cells(1, 7) = "UseCommonRobotStartDateTime"
Cells(2, 1).CopyFromRecordset RS
MyFileName = "DKRateReview" & Replace(Date, "/", "") & ".xlsx"
MyBook.SaveAs Environ("UserProfile") & "\Desktop" & MyFileName
MyBook.Close
FileName.lblInstr.Caption = "This file has been saved on your desktop. Please load as a part number pull using the file name below."
FileName.txtFileName = MyFileName
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.Navigate "http://txkapow01/CompetitiveEdge/Par...thod=automatic"
FileName.Show
End Sub
Macro 2: