Re: updating or replacing multiple values in one field

Anthony- thank you for your efforts on this I did as you explained however it
bombs at GetImportStats I have tried several things but cannot seem work
around this. Was it possibly a written funcito I could not find it in the
Object library anywhere.

Any suggestions?

Anthony England wrote:
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
[quoted text clipped - 30 lines]
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

--
Message posted via AccessMonster.com
http://www.accessmonster.com/Uwe/Forums.aspx/databases-ms-access/200602/1
.

Relevant Pages