pa****@zembra.net wrote in
news:11********************@j33g2000cwa.googlegrou ps.com:
Thanks a lot, this is exactly what I wouln need but I'm
clueless when it comes to writing this VB code. Is there a
place where I can find such code or is it possible toput that
code into the group ?
Pascal
Paste into a module. (watch for line wrapping)
Option Compare Database
Option Explicit
Dim strSQL As String
Dim strSQL2 As String
Dim db As Database
Dim rsSource(9) As Recordset
Dim rsTarget As Recordset
Dim tblname As String
Dim Seqno As Long
'============================
Public Sub Explode(ByVal RootItem As String)
'============================
On Error GoTo Explode_Error
Const LPN = 38
Seqno = 0
'--------------------------------------------
'Create a structure to receive the data
'--------------------------------------------
tblname = "XL" & RootItem
strSQL = "CREATE TABLE [" & tblname & "] (" _
& "Seqno long," & vbNewLine _
& "LLno integer," & vbNewLine _
& "Item text(" & LPN & ")," & vbNewLine _
& "Item_Name TEXT(64)," & vbNewLine _
& "Qty double," & vbNewLine _
& "UM text(6)," & vbNewLine _
& "Qty_Expl Double," & vbNewLine _
& "SeqNHA long," & vbNewLine _
& "CONSTRAINT seqno PRIMARY KEY (seqno)" & vbNewLine _
& ");"
DoCmd.RunSQL strSQL
Set db = CurrentDb
Set rsTarget = db.OpenRecordset(tblname)
'-------------------------------------------
' Set up source query
strSQL = "SELECT ProductStructure.Parent_ITEM, " & vbNewLine _
& "child_Items.ITEM_KEY," & vbNewLine _
& "child_Items.ITEM_NAME," & vbNewLine _
& "ProductStructure.Quantity," & vbNewLine _
& "ProductStructure.UM," & vbNewLine
strSQL = strSQL & "FROM ProductStructure INNER JOIN ITEM_Master
AS Child_Items " & vbNewLine _
& "ON (ProductStructure.child_ITEM = child_Items.ITEM_KEY)"
& vbNewLine
strSQL = strSQL & "WHERE (ProductStructure.Parent_ITEM) = '"
strSQL2 = "' ORDER BY Child_Items.ITEM_KEY;"
doOneRow RootItem, 0, 0, 1
Explode_exit:
rsTarget.Close
Set rsSource(9) = Nothing
Set rsTarget = Nothing
Set db = Nothing
Exit Sub
Explode_Error:
Select Case Err.Number
Case 3010 ' Table name exists
DoCmd.DeleteObject acTable, tblname
DoCmd.RunSQL strSQL ' repeat the call command
Resume Next
Case 3021 'no current record
Resume Next
Case Else
MsgBox "Please report this error to R Quintal ext xxxx" &
vbNewLine _
& Err.Number & " " & Err.Description, vbCritical
resume Explode_Exit
End Select
End Sub
'============================
Private Sub doOneRow(ByVal currentitem As String, ByVal LLno As
Long, ByVal SeqNHA As Variant, ByVal qtyNHA as double)
'============================
Dim vBkMark As Variant
Dim stCurrentRec As String
dim qtyExplode as double
Set rsSource(LLno) = db.OpenRecordset(strSQL & currentitem &
strSQL2, dbOpenDynaset)
Do Until rsSource(LLno).EOF
If rsSource(LLno).NoMatch Then
rsSource(LLno).Close
Exit Sub
Else
Seqno = Seqno + 1
QtyExplode = rsSource(LLno)!quantity * qtyNHA
With rsTarget
.AddNew
!Seqno = Seqno
!LLno = LLno
!Item = rsSource(LLno)!item_key
!item_name = rsSource(LLno)!item_name
!Qty = rsSource(LLno)!quantity
!UM = rsSource(LLno)!UM
!qty_expl = qtyExplode
!SeqNHA = SeqNHA
.Update
End With
stCurrentRec = rsSource(LLno)!item_key
vBkMark = rsSource(LLno).Bookmark
doOneRow stCurrentRec, LLno + 1, Seqno, qtyExplode
rsSource(LLno).Bookmark = vBkMark
rsSource(LLno).MoveNext
End If
Loop
End Sub
'================================== End of code
Modify as needed. Hope I didn't mangle too much while
transcribing.
Run from immediate window or code: Explode "Finish1"
--
Bob Quintal
PA is y I've altered my email address.