ACCESS FEED: RE: [MS_AccessPros] wrong forum, but excel VBA

Liz,

A healthy group of time ago I had an occasion to pull 100s of thousands of records from Access to Excel. I found that copying the data into each row, cell by cell, was TERRIBLY inefficient so I defined the set of cells into which I wanted to place the data as a range. The time savings was incredible. I've copied the code into tis message thinking that it might be an approach that you could leverage.

Jeff

Sub ADOImportFromAccessTable(strDBLoc As String, _
    TableName As String, TargetRange As Range)

Dim strSQLQuery As String

On Error GoTo HandleError

'   Suppress Screen Updates    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Set TargetRange = TargetRange.Cells(2, 1)

    ' open the database

    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & strDBLoc '& ";" & "Jet OLEDB:Database Password=" & dbOpenAttrib

    Set rs = New ADODB.Recordset
    With rs
        .Open strSQLQuery, cn, , , adCmdText
        WriteToWrksheet rs, TargetRange ' write data from the recordset to the worksheet
    End With

    Set TargetRange = Nothing

'    rs.Close
'    Set rs = Nothing
    If Not (rs Is Nothing) Then
        If (rs.State And adStateOpen) = adStateOpen Then
            rs.Close
            Set rs = Nothing
        End If
    End If
    cn.Close
    Set cn = Nothing

Exit Sub

HandleError:

'Stop
MsgBox Err & " " & Error & vbCrLf & vbCrLf & "Please contact the developer to determine the cause of the error."
'On Error Resume Next
If Not (rs Is Nothing) Then
    If (rs.State And adStateOpen) = adStateOpen Then
        rs.Close
        Set rs = Nothing
    End If
End If
If cn.State = adStateOpen Then
    cn.Close
    Set cn = Nothing
End If
End Sub     '   end ADOImportFromAccessTable

Sub WriteToWrksheet(rs As ADODB.Recordset, TargetCell As Range, Optional optCell As String)

'   Suppress Screen Updates    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

On Error GoTo HandleError

    If rs.EOF Then
'        MsgBox "There are no records in the database for the selected criteria. Please adjust the crtieria and try again."
        Exit Sub
    End If

    On Error Resume Next
    If optCell = "" Then
        optCell = "A"
    End If
    On Error GoTo HandleError

    If rs.State <> adStateOpen Then Exit Sub
    If TargetCell Is Nothing Then Exit Sub

    With Application
        .Calculation = xlCalculationManual
'        .ScreenUpdating = False
        .StatusBar = "Writing data from recordset..."
    End With

    Dim xlSht As Excel.Worksheet
    Set xlSht = Sheets(ActiveSheet.Name)

    If ActiveSheet.CodeName = "Instructions" And blnInstSheet Then
        xlSht.Range(optCell & 2).CopyFromRecordset rs
    ElseIf ActiveSheet.CodeName = "Working" Or ActiveSheet.CodeName = "WorkComments" Then
        xlSht.Range(optCell & 2).CopyFromRecordset rs
    End If

Exit Sub

HandleError:

Stop
'MsgBox Err & " " & Error & vbCrLf & vbCrLf & "Please contact the developer to determine the cause of the error."
'Resume Next
Debug.Print Err & " " & Error
Resume

End Sub     '   end WriteToWrksheet

-----Original Message-----
From: "Liz Ravenwood liz_ravenwood@beaerospace.com [MS_Access_Professionals]"
Sent: Jul 30, 2015 2:26 PM
To: "'MS_Access_Professionals@yahoogroups.com'"
Subject: RE: [MS_AccessPros] wrong forum, but excel VBA

Thanks Duane,

I'm using code given to me and the query modified to include an extra table with fields. It's recursive. Here's the code:

'Indented Bill of Material

'Inputs are Part, Date for BOM, Bubble Sort Y/N, BOM Level Code

' BOM Level Code should be input as the numeral zero

' This is a recursive, e.g. self calling function, as the code executes the BOM Level Code

' tracks indention level

Public Function IndBOMAsOfDateJDE(cn As ADODB.Connection, strPart As String, strBranchPlant As String, dtAsOfDate As Date, _

                                    strSortBy As String, blPurchID As Boolean, _

                                    Optional intBomLevelCode As Integer = 0) As Boolean





    Dim rst As ADODB.Recordset

    Dim i As Integer

    Dim blDummy As Boolean

    Dim strSQL As String

    Dim dtEffTo As Date

    Dim dtEffFrom As Date

    Dim dtHiDate As Date

    dtHiDate = #12/31/2014#

    Dim strChangeOut As String

    Dim strBubble As String

    Dim dblPriorBom As Double

    Dim strMPF As String

    Dim strComCls As String

    Dim dblQuantity As Double

    Dim strPartSQL As String

    Dim strOrderBy As String

    Dim blPurchChild As Boolean

    Dim lngJDEJulDate As Long

    Dim strUOM As String

    Dim dblOpSeq As Double

    Dim dblLine As Double

    Dim dblLdTmLvl As Double

    Dim dblLdTmCum As Double

    Dim strDescription As String

    Dim intCol As Integer

    Dim strStkTyp As String

    Dim blTest As Boolean

    Dim strSource As String

    Dim strJobNum As String



    strSource = ThisWorkbook.Worksheets("Data Entry").Range("A2").Value

    strJobNum = ThisWorkbook.Worksheets("Data Entry").Range("M11").Value



    'Convert Microsoft Julian to JDE Julian

    'lngJDEJulDate = (Year(dtAsOfDate) - 1900) * 1000 + dtAsOfDate - DateValue("12/31/" & Year(dtAsOfDate) - 1)

    lngJDEJulDate = (Year(dtAsOfDate) - 1900) * 1000 + dtAsOfDate - DateValue("01/01/" & Year(dtAsOfDate)) + 1



    'Select sort order SQL string

    Select Case strSortBy

        Case "MPF"

           strOrderBy = " ORDER BY C.F4102.IBPRP4, A.IXCPNT"

        Case "Bubble"

            strOrderBy = " ORDER BY A.IXBSEQ, A.IXCPNT"

        Case "Part"

            strOrderBy = " ORDER BY A.IXLITM, A.IXCPNT"

        Case "ComCls"

            strOrderBy = " ORDER BY C.IBPRP1, A.IXCPNT"

        Case "Line"

            strOrderBy = " ORDER BY A.IXCPNT"

        Case "OpSeq"

            strOrderBy = " ORDER BY A.IXOPSQ, A.IXCPNT"

        Case Else

            strOrderBy = " ORDER BY A.IXCPNT"

    End Select





    'Set up SQL String for Indented BOM Data

    If intBomLevelCode Then     'Parent test 0 = False

' 7/24/2015 ATTEMPT to bring in F0911 data for filtering by job code (prog/ss) and then detail items to include the workorder

        strSQL = "SELECT A.IXLITM AS Part, D.IMDSC1 AS Description, " & _

        "B.IXKIT AS Test, C.IBPRP1 AS ComCls, C.IBPRP4 AS MPF, " & _

        "C.IBLTLV AS LdTmLvl, C.IBLTCM AS LdTmCum, A.IXBSEQ AS Bubble, " & _

        "A.IXQNTY AS Quantity, A.IXEFFF AS EffFrom, A.IXEFFT AS EffTo, " & _

        "A.IXCPNT AS Line, A.IXUM AS UOM, A.IXOPSQ AS OpSeq, C.IBSTKT AS StkTyp, " & _

        " SUM(CASE WHEN E.IECOST = 'A1' THEN CAST(E.IECSL AS FLOAT) / 10000" & _

           " ELSE CAST(0 AS FLOAT) END) AS MaterialCOST," & _

        " SUM(CASE WHEN E.IECOST = 'B1' THEN CAST(E.IECSL AS FLOAT) / 10000" & _

           " ELSE CAST(0 AS FLOAT) END) AS LaborCOST," & _

        " SUM(CASE WHEN E.IECOST = 'C4' THEN CAST(E.IECSL AS FLOAT) / 10000" & _

           " ELSE CAST(0 AS FLOAT) END) AS OverheadCOST, " & strSource & ".F0911.GLDOC AS WO, " & strSource & ".F0911.GLOBJ AS Object"

        strSQL = strSQL & " FROM " & strSource & ".F3002 AS A LEFT OUTER JOIN " & strSource & ".F3002 AS B ON A.IXCMCU = B.IXMMCU AND A.IXITM = B.IXKIT" & _

        " INNER JOIN " & strSource & ".F4102 AS C ON A.IXITM = C.IBITM AND A.IXCMCU = C.IBMCU" & _

        " INNER JOIN " & strSource & ".F4101 AS D ON A.IXITM = D.IMITM INNER JOIN " & strSource & ".F30026 AS E ON C.IBITM = E.IEITM AND C.IBMCU = E.IEMMCU" & _

        " INNER JOIN " & strSource & ".F0911 ON A.IXLITM = " & strSource & ".F0911.GLEXR" & _

        " WHERE     (A.IXKITL = '" & strPart & "') AND (A.IXMMCU = '" & strBranchPlant & "') AND (A.IXTBM = 'M')" & _

        " AND (A.IXEFFF <" & lngJDEJulDate & ") AND (A.IXEFFT >=" & lngJDEJulDate & ") AND " & _

        "(" & strSource & ".F0911.GLOBJ BETWEEN '200000' AND '999999') AND (SUBSTRING(" & strSource & ".F0911.GLMCU, 5, 8) = '" & strJobNum & "')" & _

        " GROUP BY A.IXLITM, D.IMDSC1, B.IXKIT, C.IBPRP1, C.IBPRP4, C.IBLTLV, C.IBLTCM, A.IXBSEQ, A.IXQNTY, A.IXEFFF, A.IXEFFT, A.IXCPNT, A.IXUM, A.IXOPSQ, C.IBSTKT, " & _

        strSource & ".F0911.GLEXR , " & strSource & ".F0911.GLDOC " & "ORDER BY Line"



    Else                    'When Parent

' 7/24/2015 ATTEMPT to bring in F0911 data for filtering by job code (prog/ss) and then detail items to include the workorder and the object code

       strSQL = "SELECT     A.IMLITM AS Part, A.IMDSC1 AS Description, A.IMUOM1 AS UOM, B.IBPRP1 AS ComCls, 0 AS Bubble, B.IBPRP4 AS MPF, B.IBLTLV AS LdTmLvl, " & _

          " B.IBLTCM AS LdTmCum, 10000 AS Quantity, 0 AS Line, 0 AS OpSeq, 0 AS Test, 115206 AS EffFrom, 114365 AS EffTo, B.IBSTKT AS StkTyp," & _

          " SUM(CASE WHEN C.IECOST = 'A1' THEN CAST(C.IECSL AS FLOAT) / 10000 ELSE CAST(0 AS FLOAT) END) AS MaterialCOST," & _

          " SUM(CASE WHEN C.IECOST = 'B1' THEN CAST(C.IECSL AS FLOAT) / 10000 ELSE CAST(0 AS FLOAT) END) AS LaborCOST," & _

          " SUM(CASE WHEN C.IECOST = 'C4' THEN CAST(C.IECSL AS FLOAT) / 10000 ELSE CAST(0 AS FLOAT) END) AS OverheadCOST, " & strSource & ".F0911.GLDOC as WO" & _

          " FROM " & strSource & ".F4101 AS A INNER JOIN " & _

          strSource & ".F4102 AS B ON A.IMITM = B.IBITM INNER JOIN " & _

          strSource & ".F30026 AS C ON B.IBITM = C.IEITM AND B.IBMCU = C.IEMMCU INNER JOIN " & _

          strSource & ".F0911 ON A.IMLITM = WORLD.F0911.GLEXR" & _

         " WHERE     (A.IMLITM = '5ZK001CH501') AND (B.IBMCU = '     6150001') AND (C.IELEDG = '07') AND (C.IECOST = 'A1' OR C.IECOST = 'B1' OR C.IECOST = 'C4') AND (" & _

         strSource & ".F0911.GLOBJ BETWEEN '200000' AND '999999') AND (SUBSTRING(" & strSource & ".F0911.GLMCU, 5, 8) = '" & strJobNum & "')" & _

         " GROUP BY A.IMLITM, A.IMDSC1, A.IMUOM1, B.IBPRP1, B.IBPRP4, B.IBLTLV, B.IBLTCM, B.IBSTKT, " & strSource & ".F0911.GLDOC"

        Debug.Print "2nd select statement"

    End If

    Set rst = Nothing

    Set rst = cn.Execute(strSQL)



    Do While Not rst.EOF

        'Part

            strPart = rst!Part

        Debug.Print strPart



        'BubSeq

        If IsNull(rst!Bubble) Then

            strBubble = Chr$(32)

        Else

            strBubble = rst!Bubble

        End If



        'Qty

        If IsNull(rst!QUANTITY) Then

            dblQuantity = 0

        Else

            dblQuantity = rst!QUANTITY / 10000

        End If



        'EffFrom Convert JDE Julian to MS Julian/Date

        dtEffFrom = DateValue("12/31/" & (Int(rst!EffFrom / 1000)) + 1899) + (rst!EffFrom - Int(rst!EffFrom / 1000) * 1000)



        'EffTo

         dtEffTo = DateValue("12/31/" & (Int(rst!EffTo / 1000)) + 1899) + (rst!EffTo - Int(rst!EffTo / 1000) * 1000)



        'Line

        If IsNull(rst!Line) Then

            dblLine = 0

        Else

            dblLine = rst!Line / 10

        End If



        'UOM

        strUOM = rst!uom



        'OpSeq

        If IsNull(rst!OpSeq) Then

            dblOpSeq = 0

        Else

            dblOpSeq = rst!OpSeq / 100

        End If



        'ComCls

        If IsNull(rst!ComCls) Then

            strComCls = Chr$(32)

        Else

            strComCls = rst!ComCls

        End If



        'MPF

        If IsNull(rst!MPF) Then

            strMPF = " "

        Else

            strMPF = rst!MPF

        End If



        'Lead Time Level

        If IsNull(rst!ldtmlvl) Then

            dblLdTmLvl = 0

        Else

            dblLdTmLvl = rst!ldtmlvl

        End If



        'Lead Time Cumulative

        If IsNull(rst!LdTmCum) Then

            dblLdTmCum = 0

        Else

            dblLdTmCum = rst!LdTmCum

        End If



        'Test

        If IsNull(rst!Test) Then

            blTest = False 'No BOM Exists

        Else

            'If BOM Exist do we want purch explosion

            If blPurchID = False And rst!stktyp = "P" Then

                blTest = False

            Else

                blTest = True

            End If



        End If



        'StkTyp

        If IsNull(rst!stktyp) Then

            strStkTyp = Chr$(32)

        Else

            strStkTyp = rst!stktyp

        End If



        'Description

        If IsNull(rst!Description) Then

            strDescription = Chr$(32)

        Else

            strDescription = rst!Description

        End If



        'Branch Plant

        If Left$(strBranchPlant, 5) <> "     " Then

            strBranchPlant = "     " & strBranchPlant

        End If





        '*********************************************************

        'Excel Routine Here to write out data and move to next line

        '*********************************************************



        'Write out data

        ActiveCell.Value = intBomLevelCode

        ActiveCell.Offset(0, 1).Value = strPart

        ActiveCell.Offset(0, 2).Value = strDescription

        ActiveCell.Offset(0, 3).Value = strStkTyp

        ActiveCell.Offset(0, 4).Value = dblLine

        ActiveCell.Offset(0, 5).Value = dblQuantity

        ActiveCell.Offset(0, 6).Value = strUOM

        ActiveCell.Offset(0, 7).Value = strBubble

        ActiveCell.Offset(0, 8).Value = dblOpSeq

        ActiveCell.Offset(0, 9).Value = dtEffFrom

        ActiveCell.Offset(0, 10).Value = dtEffTo

        ActiveCell.Offset(0, 11).Value = strComCls

        ActiveCell.Offset(0, 12).Value = strMPF

        ActiveCell.Offset(0, 13).Value = dblLdTmLvl

        ActiveCell.Offset(0, 14).Value = dblLdTmCum

        ActiveCell.Offset(0, 15).Value = rst("MaterialCOST")

        ActiveCell.Offset(0, 16).Value = rst("LaborCOST")

        ActiveCell.Offset(0, 17).Value = rst("OverheadCOST")

        ActiveCell.Offset(0, 18).Value = rst("WO")





        'Move to next row

        intCol = -ActiveCell.Column + 1

        ActiveCell.Offset(1, intCol).Activate



        blPurchChild = blPurchID



        '*************************************************************

        'Recursion

      '*************************************************************

        If blTest = True Then

            blDummy = IndBOMAsOfDateJDE(cn, rst!Part, strBranchPlant, dtAsOfDate, strSortBy, blPurchID, intBomLevelCode + 1)

        End If



        rst.MoveNext

    Loop

    rst.Close



End Function

From: MS_Access_Professionals@yahoogroups.com [mailto:MS_Access_Professionals@yahoogroups.com]
Sent: Thursday, July 30, 2015 11:10 AM
To: Access Professionals Yahoo Group
Subject: RE: [MS_AccessPros] wrong forum, but excel VBA

You shouldn't need to worry about "pending" at http://www.tek-tips.com/threadminder.cfm?pid=707.

Regarding your issue, are you importing data to Excel or exporting data from Excel? I do a lot of exporting from Excel to SQL server and have found creating some batch type uploads of about 50 records at a time cuts my processing time significantly.

Duane Hookom, MVP
MS Access

To: MS_Access_Professionals@yahoogroups.com
CC: Richard_Miller@beaerospace.com; Hal_McGee@beaerospace.com
From: MS_Access_Professionals@yahoogroups.com
Date: Thu, 30 Jul 2015 17:23:16 +0000
Subject: [MS_AccessPros] wrong forum, but excel VBA

Pros, I understand if this is ignored as I am pending membership to a more appropriate forum, but thought I'd throw it out here since traffic is light right now and there are so many VBA pros.

I have an excel file with an ODBC connection to an SQL Server using ADO. The code is running a bill of materials that could easily be 15 to 20 thousand lines and when I run it I can't interact with my computer since it is moving from row to row, cell to cell, and populating recordset retrieval information.

I started it up at 3:30 and ran it until about 8PM last night and it only ran 4800 lines and our Citrix network will naturally time the process out.

Is there anyway I could do either/and 1. Speed this up 2. Run in the background 3. Automate it by some sleeper or task?

I can't use my task manager as that is a windows process and I need this to run WITHIN the intranet using the Citrix connection.

Ideas anyone?

Respectfully,

Liz Ravenwood

Programmer / Analyst

B/E Aerospace | Super First Class Environments

1851 S Pantano Road | Tucson, Arizona 85710

Office +1.520.239.4808 | Internal 814-4808

beaerospace.com

Passion to Innovate. Power to Deliver

This email (and all attachments) is for the sole use of the intended recipient(s) and may contain privileged and/or proprietary information. Any unauthorized review, use, disclosure or distribution is prohibited. If you are not the intended recipient, please contact the sender by reply e-mail and destroy all copies of the original message.

This email (and all attachments) is for the sole use of the intended recipient(s) and may contain privileged and/or proprietary information. Any unauthorized review, use, disclosure or distribution is prohibited. If you are not the intended recipient, please contact the sender by reply e-mail and destroy all copies of the original message.