Append query VBA?

[Tango]

I have an append query that pulls records from one table and adds them to another table while inserting some default data. What I would like to do is make that same query or VBA tied to a button that will take the source table and create multiple copies of that record into the output table based on the content in one field of the records in the source table.

i.e.

Table one has 6 columns per record. Column 6 is a textbox that will contain string names seperated by a ; symbol like bob;joe;susan.

What I want to have happen is either the VBA or the append query will insert into table 2, three records, since their were three names listed in that field. So what was one record in table 1 will now be three records in table 2. Each record will still have column 6 but it will now contain only one string so one record will have Bob one record will have Joe and the last will have Sue.

Some records in table 1 will have only one name in column 6 while others might have half a dozen.

I'm thinking it will have to be a "for every ;" kind of loop but I have no idea how to write it.

 

[G37Sam]

You'd have to start off by counting the names by basically counting the number of semicolons in that column.

Once done, you will repeat the (INSERT INTO) SQL statement based on the number of names you counted using a simple For..Next loop.

 

[Tango]

Awsome, I don't suppose you can give me an example I can use to piece this together?

INSERT INTO tblActiveMaster ( [Line Number], Question, AFI, PagePara, PubDate, UnitAssigned, DateAssigned, SuspenceDate, AssignedBy, Status, CriticalYN )
SELECT tblMasterChecklist.[Line Number], tblMasterChecklist.Question, tblMasterChecklist.AFI, tblMasterChecklist.PagePara, tblMasterChecklist.PubDate, tblMasterChecklist.Units, Now() AS AssignedDate, Now()+30 AS DueBy, [Forms]![frmAssignChecklistAdmin]![curuser] AS AssignedBy, "Open" AS SetOpen, "0" AS [SetCritical no]
FROM tblMasterChecklist
WHERE (((tblMasterChecklist.CycleNumber) Like [Forms]![frmAssignChecklistAdmin]![CycleNumber]));

Thats my append query as it stands now. the "Units" column is the one that has the names seperated by ";". The destination table column is "UnitAssigned". I'm trying to learn how to apply this to future problems as well. Again, thanks for the quick reply. Gotta love these forums.

 

[G37Sam]

So let's say intCountedNames contains the number of counted names and that you created an array to store the inStr locations of the names and called it NameLocation. (Don't forget to remove the semicolons when done using the Replace function)

The array would look something like:

NameLocation(1) = 1 (Hardcoded, bob starts here)
NameLocation(2) = 4 (Joe starts here)
NameLocation(3) = 7 (Susan starts here)
NameLocation(4) = 11 (Susan ends here)

For i = 1 to CountedNames
    currentdb.execute "INSERT INTO tblname Values ('" & dlookup("mid(column6," & namelocation(i) & "," & namelocation(i+1) - namelocation(i) & ","YourTableName"
Next i

 

[Tango]

Thanks, I'll try to piece it together in the morning and let you know.

 

[G37Sam]

Great!

Get the function to count and import the namelocations working first then move on to the next challenge and do keep us posted pleaes

 

[Tango]

I found this from Allen Browne that looks like it does most of what I was trying to do. The next step is to somehow convert the varphrase variable to look at the field in the table and to change the iWordNum to keep cycling up until it returns a null.

I have no idea how to do either lol.

Function ParseWord(varPhrase As Variant, ByVal iWordNum As Integer, Optional strDelimiter As String = ";", _
    Optional bRemoveLeadingDelimiters As Boolean, Optional bIgnoreDoubleDelimiters As Boolean) As Variant
On Error GoTo Err_Handler
    'Purpose:   Return the iWordNum-th word from a phrase.
    'Return:    The word, or Null if not found.
    'Arguments: varPhrase = the phrase to search.
    '           iWordNum = 1 for first word, 2 for second, ...
    '               Negative values for words form the right: -1 = last word; -2 = second last word, ...
    '               (Entire phrase returned if iWordNum is zero.)
    '           strDelimiter = the separator between words. Defaults to a space.
    '           bRemoveLeadingDelimiters: If True, leading delimiters are stripped.
    '               Otherwise the first word is returned as null.
    '           bIgnoreDoubleDelimiters: If true, double-spaces are treated as one space.
    '               Otherwise the word between spaces is returned as null.
    'Author:    Allen Browne. [URL]http://allenbrowne.com[/URL]. June 2006.
    Dim varArray As Variant     'The phrase is parsed into a variant array.
    Dim strPhrase As String     'varPhrase converted to a string.
    Dim strResult As String     'The result to be returned.
    Dim lngLen As Long          'Length of the string.
    Dim lngLenDelimiter As Long 'Length of the delimiter.
    Dim bCancel As Boolean      'Flag to cancel this operation.
    '*************************************
    'Validate the arguments
    '*************************************
    'Cancel if the phrase (a variant) is error, null, or a zero-length string.
    If IsError(varPhrase) Then
        bCancel = True
    Else
        strPhrase = Nz(varPhrase, vbNullString)
        If strPhrase = vbNullString Then
            bCancel = True
        End If
    End If
    'If word number is zero, return the whole thing and quit processing.
    If iWordNum = 0 And Not bCancel Then
        strResult = strPhrase
        bCancel = True
    End If
    'Delimiter cannot be zero-length.
    If Not bCancel Then
        lngLenDelimiter = Len(strDelimiter)
        If lngLenDelimiter = 0& Then
            bCancel = True
        End If
    End If
    '*************************************
    'Process the string
    '*************************************
    If Not bCancel Then
        strPhrase = varPhrase
        'Remove leading delimiters?
        If bRemoveLeadingDelimiters Then
            strPhrase = Nz(varPhrase, vbNullString)
            Do While Left$(strPhrase, lngLenDelimiter) = strDelimiter
                strPhrase = Mid(strPhrase, lngLenDelimiter + 1&)
            Loop
        End If
        'Ignore doubled-up delimiters?
        If bIgnoreDoubleDelimiters Then
            Do
                lngLen = Len(strPhrase)
                strPhrase = Replace(strPhrase, strDelimiter & strDelimiter, strDelimiter)
            Loop Until Len(strPhrase) = lngLen
        End If
        'Cancel if there's no phrase left to work with
        If Len(strPhrase) = 0& Then
            bCancel = True
        End If
    End If
    '*************************************
    'Parse the word from the string.
    '*************************************
    If Not bCancel Then
        varArray = Split(strPhrase, strDelimiter)
        If UBound(varArray) >= 0 Then
            If iWordNum > 0 Then        'Positive: count words from the left.
                iWordNum = iWordNum - 1         'Adjust for zero-based array.
                If iWordNum <= UBound(varArray) Then
                    strResult = varArray(iWordNum)
                End If
            Else                        'Negative: count words from the right.
                iWordNum = UBound(varArray) + iWordNum + 1
                If iWordNum >= 0 Then
                    strResult = varArray(iWordNum)
                End If
            End If
        End If
    End If
    '*************************************
    'Return the result, or a null if it is a zero-length string.
    '*************************************
    If strResult <> vbNullString Then
        ParseWord = strResult
    Else
        ParseWord = Null
    End If
Exit_Handler:
    Exit Function
Err_Handler:
    Call LogError(Err.Number, Err.Description, "ParseWord()")
    Resume Exit_Handler
End Function

 

[Tango]

Well I managed to have an update query count the number or names in each field for each record so now I have a column in the source table that tells it how many records to make from that one source record. Havnt figured out how to use that yet...

 

[Tango]

Great!

Get the function to count and import the namelocations working first then move on to the next challenge and do keep us posted pleaes

Got the count but I'm stumped on the namelocation part. Any hints?

 

[Tango]

I have it ALMOST working. Every step I need to have happen is happening except for one. I need to parse the "UnitAssigned" field down to one name per record. Again, each name is seperated by a ";" and I have already captured as a variable the number of names in each record. Seperating the names is what has me stumped now.

Here is the code I have and it works as I wanted it to. I just hope one of you guys can help me add the above function into this code.

Public Function fDupRecord()
Dim db As DAO.Database
Dim rst_input As DAO.Recordset
Dim counter As Integer
Dim unit_array() As Variant
Dim row_cnt As Integer
Dim unit_counter As Integer
Set db = CurrentDb()
'array used to assemble the figures
' change the value 20000 in the next line to more than the number of records
ReDim unit_array(20000, 19)

Set rst_input = db.OpenRecordset("tblMasterChecklistTEMP", dbOpenDynaset)
row_cnt = 0
With rst_input
If .RecordCount > 0 Then
.MoveFirst
Do Until .EOF
unit_array(row_cnt, 0) = ![UnitCount]
unit_array(row_cnt, 1) = ![Line Number]
unit_array(row_cnt, 2) = ![Question]
unit_array(row_cnt, 3) = ![AFI]
unit_array(row_cnt, 4) = ![PagePara]
unit_array(row_cnt, 5) = ![PubDate]
unit_array(row_cnt, 6) = ![UnitAssigned]
unit_array(row_cnt, 7) = ![CycleNumber]
unit_array(row_cnt, 8) = ![DateAssigned]
unit_array(row_cnt, 9) = ![SuspenceDate]
unit_array(row_cnt, 16) = ![Status]
unit_array(row_cnt, 18) = ![AssignedBy]
 
.MoveNext
row_cnt = row_cnt + 1
Loop
End If ' record count
End With
'create table from assembled array
counter = 0
Do Until counter > row_cnt - 1 ' deduct 1 from row_cnt as the above code has added 1.
' This will prevent a blank record added as a last record
If unit_array(counter, 0) > 1 Then
unit_counter = 2 ' 1st record already added
Debug.Print unit_array(counter, 0)
Do Until unit_counter > unit_array(counter, 0)
rst_input.AddNew
rst_input("UnitCount") = unit_array(counter, 0)
rst_input("Line Number") = unit_array(counter, 1)
rst_input("Question") = unit_array(counter, 2)
rst_input("AFI") = unit_array(counter, 3)
rst_input("PagePara") = unit_array(counter, 4)
rst_input("PubDate") = unit_array(counter, 5)
rst_input("UnitAssigned") = unit_array(counter, 6)
rst_input("CycleNumber") = unit_array(counter, 7)
rst_input("DateAssigned") = unit_array(counter, 8)
rst_input("SuspenceDate") = unit_array(counter, 9)
rst_input("Status") = unit_array(counter, 16)
rst_input("AssignedBy") = unit_array(counter, 18)

rst_input.Update
unit_counter = unit_counter + 1
Loop
End If ' number of unit
counter = counter + 1
Loop
MsgBox "Units records have been split and merged into the main table."
End Function

 

[G37Sam]

Ok I found an even easier solution to this

Dim i As Integer, iPrevious As Integer, strNames As String, tempName As String
strNames = DLookup("column6", "table1")

'add a trailing semicolon to check end of string later
If Right(strNames, 1) <> ";" Then
    strNames = strNames & ";"
End If

i = 1
Do While i < Len(strNames)
    iPrevious = i
    i = InStr(i, strNames, ";") + 1
    tempName = Mid(strNames, iPrevious, i - iPrevious - 1)
    CurrentDb.Execute "INSERT INTO table2 Values ('" & tempName & "')"
Loop

And attached is a DB of it in action

View attachment TangoDB.mdb

 

[Tango]

Thats exactly what I need, thank you so much. I've been toying with it for a few hours now though and havn't had much luck merging the two functions. I'll keep playing with it until I hear back from you again.

Is your code ment to replace my code above as an alternative or is it supposed to be merged into it?

 

[G37Sam]

Yeah I'm sorry I lead you into a longer route with the whole array business. After I started working on it I figured there was an even easier way, which was the one I posted.

You just need to replace "column6" and table1 & table2 with your actual field and table names that's all

 

[Tango]

I'll need to add the reference for the other fields in the table as well so that it carries them down... correct?

 

[G37Sam]

Only if you're moving other data along with the Names

 

[Tango]

I am moving the entire record down with each name. I started modifying your code with that in mind and here is what I have so far.

Dim i As Integer, iPrevious As Integer, strNames As String, tempName As String, UC As Integer, LineNum As String, Qstn As String, AF As String, PP As String, pubD As String, CycleNum As Integer, Dassign As String, suspDate As String, Crit As Integer, assignby As String
strNames = DLookup("UnitAssigned", "tblmasterchecklisttemp")
UC = DLookup("UnitCount", "tblmasterchecklisttemp")
LineNum = DLookup("Line Number", "tblmasterchecklisttemp")
Qstn = DLookup("Question", "tblmasterchecklisttemp")
AF = DLookup("AFI", "tblmasterchecklisttemp")
PP = DLookup("PagePara", "tblmasterchecklisttemp")
pubD = DLookup("PubDate", "tblmasterchecklisttemp")
CycleNum = DLookup("CycleNumber", "tblmasterchecklisttemp")
Dassign = DLookup("DateAssigned", "tblmasterchecklisttemp")
suspDate = DLookup("SuspenceDate", "tblmasterchecklisttemp")
Crit = DLookup("CriticalYN", "tblmasterchecklisttemp")
assignby = DLookup("AssignedBy", "tblmasterchecklisttemp")
'add a trailing semicolon to check end of string later
If Right(strNames, 1) <> ";" Then
    strNames = strNames & ";"
End If
i = 1
Do While i < Len(strNames)
    iPrevious = i
    i = InStr(i, strNames, ";") + 1
    tempName = Mid(strNames, iPrevious, i - iPrevious - 1)
    CurrentDb.Execute "INSERT INTO tblActiveMaster Values ('" & tempName & "')"
Loop
End Sub

I am pretty sure this is the last piece that needs to be edited for this to work but I dont know the syntax.

CurrentDb.Execute "INSERT INTO tblActiveMaster Values ('" & tempName & "')"

 

[G37Sam]

Well now that you have more than one field, you're going to have to mention to which field every piece of data goes

"INSERT INTO tblActiveMaster(field1,field2,field3) Values ('" & tempName & "'," & UC & "," & LineNum & ")"

Remember, strings need to be wrapped with single quotes and dates have to be wrapped with hash. Integers don't require any sort of wrap (I assumed UC & LineNum are integers)

 

[Tango]

Like this?

    CurrentDb.Execute "INSERT INTO tblActiveMaster(UnitCount,Line Number,Question, AFI, PagePara, PubDate, UnitAssigned, CycleNumber, DateAssigned, SuspenceDate, CriticalYN, AssignedBy) Values ('" & tempName & "'," & UC & "," & LineNum & ")"

Do the entries have to be in the same order as the fields?

 

[G37Sam]

Yes, here's more on how INSERT INTO works

http://www.w3schools.com/sql/sql_insert.asp

 

[Tango]

I probably butchered it but here is what I wrote in.

CurrentDb.Execute "INSERT INTO tblActiveMaster(UnitCount, Line Number, Question, AFI, PagePara, PubDate, UnitAssigned, CycleNumber, DateAssigned, SuspenceDate, CriticalYN, AssignedBy) Values (UC,'" & LineNum & "','" & Qstn & "','" & AF & "','" & PP & "','" & pubD & "','" & tempName & "', CycleNum,'" & Dassign & "','" & suspDate & "', Crit,'" & assignby & "')"
Loop

The only integers are the CycleNum, UC, and Crit fields