I admit that I haven't played computer to walk through the code as my finely tuned body discovered another opportunity that needs corrective actions so I'm not sitting in front of the computer very much.
-----Original Message-----
From: "Liz Ravenwood liz_ravenwood@beaerospace.com [MS_Access_Professionals]"
Sent: Jul 30, 2015 4:57 PM
To: "'MS_Access_Professionals@yahoogroups.com'"
Cc: Hal McGee
Subject: 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
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.
---
Jeffrey Park Jones
919-671-9870
119 Ayersdale Dr.
Taylors, SC 29687
---
Jeffrey Park Jones
919-671-9870
119 Ayersdale Dr.
Taylors, SC 29687
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.
Jeffrey Park Jones
919-671-9870
119 Ayersdale Dr.
Taylors, SC 29687
Posted by: Jeff <jpjones23@earthlink.net>
| Reply via web post | • | Reply to sender | • | Reply to group | • | Start a New Topic | • | Messages in this topic (7) |
Tidak ada komentar:
Posting Komentar