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

Thanks Jeff. Good story and congratulations.

Unfortunately, I'm thinking on first look that this won't work because of the recursion issue.

Hal, what do you think?

From: MS_Access_Professionals@yahoogroups.com [mailto:MS_Access_Professionals@yahoogroups.com]
Sent: Thursday, July 30, 2015 1:42 PM
To: AccessGroup
Subject: 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

'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.