Results 1 to 4 of 4
  1. #1
    natonstan is offline Advanced Beginner
    Windows 8 Access 2013
    Join Date
    Oct 2014
    Posts
    37

    Combining Two Procedures

    I have two macros, I usually run Macro 1, then run macro 2 on the same sheet.

    Macro 1:


    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:
    Code:
    Option Explicit
    Sub DkRateVarianceMacro()
    Dim myBook As Workbook
    Dim CADsheet, Summarysheet, DKData As Worksheet
    Dim myRow, myCol, DKVar, myRange As Long
    Dim mySupRange As Long
    ' Setting Active Workbook
    Set myBook = ActiveWorkbook
    Set CADsheet = myBook.Sheets("CAD")
    Set Summarysheet = myBook.Sheets("CurrenciesAndDeviantSuppliers")
    ' Pulls the Supplier names from the DK Rate Sheet
    Sheets.Add.Name = "DKRateVariances"
    Set DKData = ActiveSheet
    myRow = 4
    myCol = 4
    Do Until CADsheet.Cells(2, myCol) = ""
        DKData.Cells(myRow, 1) = CADsheet.Cells(2, myCol)
        myCol = myCol + 1
        myRow = myRow + 1
        
    ' Pulls the Currency labels from DK Rate Sheet
    Loop
    myRow = 5
    myCol = 2
    Do Until myBook.Sheets("Summary").Cells(myRow, 1) = ""
        DKData.Cells(2, myCol) = myBook.Sheets("Summary").Cells(myRow, 1)
        DKData.Cells(3, myCol) = myBook.Sheets("Summary").Cells(myRow, 7)
        DKData.Cells(1, myCol) = myBook.Sheets("Summary").Cells(myRow, 2)
        myRow = myRow + 1
        myCol = myCol + 1
    Loop
    myRow = 4
    myCol = 2
    Do Until DKData.Cells(2, myCol) = ""
        Summarysheet.Activate
        myRange = Cells.Find(What:=DKData.Cells(1, myCol), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Row
        DKVar = 4
        Do Until Summarysheet.Cells(myRange, DKVar) = ""
            DKData.Activate
            mySupRange = Cells.Find(What:=Summarysheet.Cells(myRange, DKVar), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Row
            If (Summarysheet.Cells(myRange + 4, DKVar) - Summarysheet.Cells(myRange + 4, 2)) / Summarysheet.Cells(myRange + 4, 2) <> 0 Then
                DKData.Cells(mySupRange, myCol) = (Summarysheet.Cells(myRange + 4, DKVar) - Summarysheet.Cells(myRange + 4, 2)) / Summarysheet.Cells(myRange + 4, 2)
                DKData.Cells(mySupRange, myCol).NumberFormat = "0.00%"
            End If
            DKVar = DKVar + 1
            
        
        
        Loop
        DKData.Cells(1, myCol) = ""
        
        myRow = myRow + 1
        myCol = myCol + 1
    Loop
    ' Formatting Cells
    DKData.Cells(1, 1) = "DK Rate Variance Percentage By Supplier"
    DKData.Cells(3, 1) = "Digikey Sales Rate"
    DKData.Cells(1, 1).Interior.ColorIndex = 15
    DKData.Range("B3:P3").Interior.ColorIndex = 15
    DKData.Cells(1, 1).Font.Bold = True
    DKData.Range("A3:A86").Font.Bold = True
    DKData.Range("B2:P2").Font.Bold = True
    DKData.Range("B3:P3").Font.Bold = True
    DKData.Range("B2:P2").Interior.ColorIndex = 15
    DKData.Range("A1:P1").Merge
    DKData.Range("A3:P86").Borders.LineStyle = xlContinuous
    DKData.Cells(1, 1).HorizontalAlignment = xlCenter
    DKData.Range("A2:A86").Interior.ColorIndex = 15
    DKData.Range("A:P").Columns.AutoFit
     
    
    End Sub
    Both macros run fine separately, would it simply be a case of replacing the End Sub at the end of the first macro and replacing with End Function?
    Last edited by RuralGuy; 08-26-2016 at 11:23 AM. Reason: Changed title.

  2. #2
    RuralGuy's Avatar
    RuralGuy is offline Administrator
    Windows 10 Access 2013 32bit
    Join Date
    Mar 2007
    Location
    8300' in the Colorado Rocky Mountains
    Posts
    12,922
    Just for the record, MS Access has the ability to create Macros. What you have posted are really Code Procedures and most developers differentiate between Macros and Code. That is why I changed your Title. You'll get more helpers that way. As for what you posted, there is nothing I can see that prevents you from creating another procedure that invokes both "macros" you have in whatever order you wish.

  3. #3
    ItsMe's Avatar
    ItsMe is offline Sometimes Helpful
    Windows 8 Access 2013
    Join Date
    Aug 2013
    Posts
    7,862
    End Function belongs at the end of Functions, not Sub Routines/Procedures.

    I don't know what you are trying to accomplish with all of that code. However, by quickly glossing over it, it seems that your computer is busy and cannot process the second sub procedure until after the first one is completed.

    Maybe adding timers and or declaring variables, closing and destroying objects, etc. will be the answer.

  4. #4
    ssanfu is offline Master of Nothing
    Windows XP Access 2010 32bit
    Join Date
    Sep 2010
    Location
    Anchorage, Alaska, USA
    Posts
    9,664
    Just so you know, you have declaration lines like
    Code:
        Dim Row, ColPrices, NumParts, x, myCol, RoundMe, SumRow, SumCol, RealSumRow, LastRow As Long
    Only the variable "LastRow" is declared as a Long. ALL of the other variables are variant types.


    Code:
    Dim MySheet, CurSheet, CurrenciesSheet, SumSheet As Worksheet
    Same here. Only "SumSheet" is declared as a worksheet. The other variables are variants.


    You MUST explicitly declare variable types or the variables are variants.
    Code:
    Dim MySheet As Worksheet, CurSheet As Worksheet, CurrenciesSheet As Worksheet, SumSheet As Worksheet
    Dim MyDb As Object, qDef As Object

Please reply to this thread with any new information or opinions.

Similar Threads

  1. Replies: 14
    Last Post: 07-22-2013, 12:39 PM
  2. Macros
    By Highlander in forum Access
    Replies: 1
    Last Post: 05-23-2012, 02:18 PM
  3. Macros
    By kstyles in forum Programming
    Replies: 2
    Last Post: 07-12-2011, 01:38 PM
  4. VBA or Macros
    By mastromb in forum Forms
    Replies: 6
    Last Post: 01-03-2010, 04:46 PM
  5. Macros
    By kfhai in forum Access
    Replies: 0
    Last Post: 04-17-2009, 08:28 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Other Forums: Microsoft Office Forums