Re: updating or replacing multiple values in one field

"Chris A via AccessMonster.com" <u2552@uwe> wrote in message
news:5b47c9684fcdb@xxxxxx
The approach is actually not vba code but a series of update queries but
before that I split the values into their own fields which turns out to be
several (up to 25 queries) while it works its too much to manage everytime
we
need to run the procedure.

I could not think of a way to do it in vb but would like to either use
that
or a function in a query. The problem I am having is the replacement
values
are variable and they are linked to the values AA, BB, EE etc. I left the
EE
value to demonstrate that so it is not a typo just a possibility.

I have never systematically updated multiple values in a field based on a
link of code AA tbl1 to AAtbl2 and replace with the value Fld2.tbl2. I
hope
this explains it better.

Anthony England wrote:
I have an interesting problem that I have yet to come accross that I
can't
change data structure on because it is an export from filemaker I am
[quoted text clipped - 34 lines]

Any help would be appreciated.

I guess the final EE in this line is a typo:
E2 April 2006 100, 200, 300, 400, EE

The approach you describe seems OK, but you are doing this all in code,
aren't you? I'm not sure what help you are looking for - a full vba
routine
to do this, or are you currently doing this manually and have little vba
coding experience?



Not wanting to get on with my own work, I have written an example of this.
Cut and paste the follwing code into a new module. You can adjust the
constants at the top to suit yourself - they should be self explanatory
except DELETE_MISSING_FIELDS which allows you to delete (or keep) values not
found in the lookup table.
Once you have pasted the code into a new module compile and save the module
as modConversion or whatever. Now you simply press CTRL-G to get the
immediate window and type in TransformData and hit return. Your results
should magically appear.

*** Of course you should run this on a copy of your database until you are
happy that the code works properly and can be trusted ***




Option Compare Database
Option Explicit

Private Const SOURCE_TABLE As String = "Table1"
Private Const LOOKUP_TABLE As String = "Table2"
Private Const TARGET_TABLE As String = "tblTransformed"
Private Const DELETE_MISSING_FIELDS As Boolean = True
Private Const MAX_FIELD_LENGTH As Integer = 6
'
'
Public Sub TransformData()

On Error GoTo Err_Handler

If TransformTable() Then
MsgBox "Conversion Complete!", vbInformation
Else
MsgBox "Error Converting Data!", vbCritical
End If

Exit_Handler:
Exit Sub

Err_Handler:
MsgBox Err.Description, vbExclamation, "Error No: " & Err.Number
Resume Exit_Handler

End Sub

Private Function TransformTable() As Boolean

On Error GoTo Err_Handler

Dim lngRecords As Long
Dim lngColumns As Long

If Not GetImportStats(lngRecords, lngColumns) Then
Exit Function
End If

If TableExists(TARGET_TABLE) Then
If Not DeleteTable(TARGET_TABLE) Then
Exit Function
End If
End If

If Not CreateTargetTable(lngColumns) Then
Exit Function
End If

If Not TransferData() Then
Exit Function
End If

If Not SwapColumns(lngColumns) Then
Exit Function
End If

TransformTable = True

Exit_Handler:
Exit Function

Err_Handler:
MsgBox Err.Description, vbExclamation, "Error No: " & Err.Number
Resume Exit_Handler

End Function


Private Function CreateTargetTable(lngLookupColumns As Long) As Boolean

On Error GoTo Err_Handler

Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Dim idx As DAO.Index
Dim strField As String
Dim lngCount As Long

Set dbs = CurrentDb

Set tdf = dbs.CreateTableDef(TARGET_TABLE)

Set fld = tdf.CreateField("ID", dbLong)
fld.Attributes = dbAutoIncrField
tdf.Fields.Append fld

Set idx = tdf.CreateIndex("ID")
idx.Primary = True

Set fld = idx.CreateField("ID")
idx.Fields.Append fld

tdf.Indexes.Append idx

Set fld = tdf.CreateField("F1", dbText, 255)
tdf.Fields.Append fld

Set fld = tdf.CreateField("F2", dbText, 255)
tdf.Fields.Append fld

For lngCount = 1 To lngLookupColumns
strField = "L" & CStr(lngCount)
Set fld = tdf.CreateField(strField, dbText, MAX_FIELD_LENGTH)
tdf.Fields.Append fld
Next lngCount

dbs.TableDefs.Append tdf

dbs.TableDefs.Refresh

CreateTargetTable = True

Exit_Handler:

If Not idx Is Nothing Then
Set idx = Nothing
End If

If Not fld Is Nothing Then
Set fld = Nothing
End If

If Not tdf Is Nothing Then
Set tdf = Nothing
End If

If Not dbs Is Nothing Then
Set dbs = Nothing
End If

Application.RefreshDatabaseWindow

Exit Function

Err_Handler:
MsgBox Err.Description, vbExclamation, "Error No: " & Err.Number
Resume Exit_Handler

End Function

Private Function TableExists(strTableName As String) As Boolean

On Error GoTo Err_Handler

Dim dbs As DAO.Database
Dim tdf As DAO.TableDef

Set dbs = CurrentDb

For Each tdf In dbs.TableDefs
If tdf.Name = strTableName Then
TableExists = True
Exit For
End If
Next tdf

Exit_Handler:

If Not dbs Is Nothing Then
Set dbs = Nothing
End If

Exit Function

Err_Handler:
MsgBox Err.Description, vbExclamation, "Error No: " & Err.Number
Resume Exit_Handler

End Function

Private Function DeleteTable(strTableName As String) As Boolean

On Error GoTo Err_Handler

Dim dbs As DAO.Database
Dim tdf As DAO.TableDef

Set dbs = CurrentDb

dbs.TableDefs.Delete strTableName

dbs.TableDefs.Refresh

DeleteTable = True

Exit_Handler:

If Not dbs Is Nothing Then
Set dbs = Nothing
End If

Application.RefreshDatabaseWindow

Exit Function

Err_Handler:
MsgBox Err.Description, vbExclamation, "Error No: " & Err.Number
Resume Exit_Handler

End Function

Private Function TransferData() As Boolean

On Error GoTo Err_Handler

Dim dbs As DAO.Database
Dim rstRead As DAO.Recordset
Dim rstWrite As DAO.Recordset
Dim strSQL As String
Dim strList As String
Dim astrValues() As String
Dim strValue As String
Dim lngField As Long
Dim lngCount As Long

Set dbs = CurrentDb

strSQL = "SELECT * FROM " & SOURCE_TABLE & " ORDER BY 1"
Set rstRead = dbs.OpenRecordset(strSQL, dbOpenForwardOnly, dbReadOnly)

strSQL = "SELECT * FROM " & TARGET_TABLE
Set rstWrite = dbs.OpenRecordset(strSQL, dbOpenDynaset, dbAppendOnly)

While Not rstRead.EOF

strList = Trim(Nz(rstRead.Fields(2), ""))
astrValues = Split(strList, ",")

rstWrite.AddNew

rstWrite.Fields(1) = rstRead.Fields(0)

rstWrite.Fields(2) = rstRead.Fields(1)

lngField = 3

For lngCount = LBound(astrValues()) To UBound(astrValues())
strValue = Trim(astrValues(lngCount))
If Len(strValue) > 0 Then
rstWrite.Fields(lngField).Value = strValue
End If
lngField = lngField + 1
Next lngCount

rstWrite.Update
rstRead.MoveNext
Wend

TransferData = True

Exit_Handler:

If Not rstWrite Is Nothing Then
rstWrite.Close
Set rstWrite = Nothing
End If

If Not rstRead Is Nothing Then
rstRead.Close
Set rstRead = Nothing
End If

If Not dbs Is Nothing Then
Set dbs = Nothing
End If

Exit Function

Err_Handler:
MsgBox Err.Description, vbExclamation, "Error No: " & Err.Number
Resume Exit_Handler

End Function

Private Function GetImportStats(lngRecords As Long, lngLookupColumns) As
Boolean

On Error GoTo Err_Handler

Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strSQL As String
Dim strList As String
Dim astrValues() As String
Dim lngColumns As Long
Dim lngCount As Long

Set dbs = CurrentDb

strSQL = "SELECT * FROM " & SOURCE_TABLE
Set rst = dbs.OpenRecordset(strSQL, dbOpenForwardOnly, dbReadOnly)

lngRecords = 0

lngLookupColumns = 0

While Not rst.EOF

lngRecords = lngRecords + 1

strList = Nz(rst.Fields(2), "")

astrValues = Split(strList, ",")

lngColumns = 0

For lngCount = LBound(astrValues()) To UBound(astrValues())
lngColumns = lngColumns + 1
Next lngCount

If lngColumns > lngLookupColumns Then
lngLookupColumns = lngColumns
End If

rst.MoveNext
Wend

GetImportStats = True

Exit_Handler:

If Not rst Is Nothing Then
rst.Close
Set rst = Nothing
End If

If Not dbs Is Nothing Then
Set dbs = Nothing
End If

Exit Function

Err_Handler:
MsgBox Err.Description, vbExclamation, "Error No: " & Err.Number
Resume Exit_Handler

End Function

Private Function SwapColumns(lngLookupColumns As Long) As Boolean

On Error GoTo Err_Handler

Dim dbs As DAO.Database
Dim lngCount As Long
Dim strSQL As String
Dim strLookupColumn1 As String
Dim strLookupColumn2 As String

If Not GetLookupNames(strLookupColumn1, strLookupColumn2) Then
Exit Function
End If

Set dbs = CurrentDb

For lngCount = 1 To lngLookupColumns

If DELETE_MISSING_FIELDS = True Then
strSQL = " LEFT JOIN "
Else
strSQL = " INNER JOIN "
End If

strSQL = "UPDATE " & TARGET_TABLE & strSQL & _
LOOKUP_TABLE & " ON " & _
TARGET_TABLE & ".L" & lngCount & " = " & _
LOOKUP_TABLE & "." & strLookupColumn1 & " SET " & _
TARGET_TABLE & ".L" & lngCount & " = " & _
LOOKUP_TABLE & "." & strLookupColumn2

dbs.Execute strSQL, dbFailOnError
Next lngCount

SwapColumns = True

Exit_Handler:

If Not dbs Is Nothing Then
Set dbs = Nothing
End If

Exit Function

Err_Handler:
MsgBox Err.Description, vbExclamation, "Error No: " & Err.Number
Resume Exit_Handler

End Function

Private Function GetLookupNames(strColumn1 As String, strColumn2 As String)
As Boolean

On Error GoTo Err_Handler

Dim dbs As DAO.Database
Dim tdf As DAO.TableDef

Set dbs = CurrentDb

Set tdf = dbs.TableDefs(LOOKUP_TABLE)

strColumn1 = tdf.Fields(0).Name

strColumn2 = tdf.Fields(1).Name

GetLookupNames = True

Exit_Handler:

If Not tdf Is Nothing Then
Set tdf = Nothing
End If

If Not dbs Is Nothing Then
Set dbs = Nothing
End If

Exit Function

Err_Handler:
MsgBox Err.Description, vbExclamation, "Error No: " & Err.Number
Resume Exit_Handler

End Function







.

Relevant Pages