"Chris A via AccessMonster.com" <u2552@uwe> wrote in message
news:5b47c9684fcdb@uwe...
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
