VBA Not Iterating Properly

[jo15765]

I have this procedure and every line works as it should except for the lines that are

            'Opening recordset that holds fields to update
            Set rs3 = db.OpenRecordset(StrSQL)
            
            'Iterating all fields that need to be altered to text
            For Each fld In rs3.Fields
            
                secondSQL = "ALTER TABLE Help ALTER COLUMN [" & fld.Value & "] TEXT(40);"
                DoCmd.RunSQL secondSQL
                
            Next
            
            'Disposing of objects
            Set fld = Nothing
            rs3.Close

This syntax will alter the first one and then immediately leave the check. How should this be updated so that each and every column in the table Help is updated to a Text(40)?

Full syntax of my VBA Is:

Private Sub btnDoIt_Click()
'Suppressing Warnings Here
DoCmd.SetWarnings False
        
'Declaring Variables
Set db = CurrentDb()
Dim fld As DAO.Field
Dim qdf As DAO.QueryDef
Dim qryDef As QueryDef
Dim rstData As DAO.Recordset
Dim StrSQL As String, AppendSQL As String
Dim CreateTableSQL As String, selectedfile As String
Dim ExtFind As String, param As String
Dim v As Variant, cn As Variant
Dim f As Object, secondSQL As String
Dim fName As Variant
 
'Dropping Table if exists
On Error Resume Next
CurrentDb.TableDefs.Delete "Help"
CurrentDb.TableDefs.Delete "Help1"


'Creating Table to house the field names that need to be altered to text
CreateTableSQL = "CREATE TABLE [Help1] (FieldPK COUNTER CONSTRAINT PrimaryKey PRIMARY KEY, fieldname TEXT);"
db.Execute CreateTableSQL


'Creating a file selector for .xls or .xlsx files
Set f = Application.FileDialog(3)


With f
    .AllowMultiSelect = False
    .Title = "Please Select the Excel File To Import"
    .Filters.Add "Excel Files", "*.xls*"


    If .Show = True Then
        For i = 1 To f.SelectedItems.Count
            'Getting file name selected
            selectedfile = f.SelectedItems(i)
            'Pulling out file extension to use proper import type
            ExtFind = Right(selectedfile, Len(selectedfile) - InStrRev(selectedfile, "."))
            If ExtFind = "xls" Then
                param = acSpreadsheetTypeExcel9
            ElseIf ExtFind = "xlsx" Then
                param = acSpreadsheetTypeExcel12
            End If
            'Importing spreadsheet into table
            DoCmd.TransferSpreadsheet acImport, param, "Help", selectedfile, True
        
            'Altering All Fields To Text
            Set rs2 = db.OpenRecordset("Help")
            For Each fld In rs2.Fields
                If fld.Name <> "ID" And fld.Name <> "Store Number" Then
                    If FieldTypeName(fld) <> "Text" Then
                        'Inserting field names to update into table since recordset is open here
                        'and the alter will fail due to this
                        StrSQL = "INSERT INTO Help1 (fieldname) VALUES ('" & fld.Name & "' );"
                        DoCmd.RunSQL StrSQL
                    End If
                End If
            Next
            
            'Disposing of Objects
            Set fld = Nothing
            rs2.Close
            
            'Building select statement to get fields to alter
            StrSQL = "select fieldname from Help1"
            
            'Opening recordset that holds fields to update
            Set rs3 = db.OpenRecordset(StrSQL)
            
            'Iterating all fields that need to be altered to text
            For Each fld In rs3.Fields
            
                secondSQL = "ALTER TABLE Help ALTER COLUMN [" & fld.Value & "] TEXT(40);"
                DoCmd.RunSQL secondSQL
                
            Next
            
            'Disposing of objects
            Set fld = Nothing
            rs3.Close
            
            'Dropping Campaigns Table if Exists
            On Error Resume Next
            CurrentDb.TableDefs.Delete "tblNames"
            
            'Creating Table
            CreateTableSQL = "CREATE TABLE [tblNames] (FieldPK COUNTER CONSTRAINT PrimaryKey PRIMARY KEY, CN TEXT);"
            db.Execute CreateTableSQL
            
            'Inserting Data Into Table
            Set rs1 = db.OpenRecordset("Help")
            For Each fld In rs1.Fields
                If fld.Name <> "ID" And fld.Name <> "Soldier Number" Then
                    StrSQL = "INSERT INTO tblNames (CN) VALUES ('" & fld.Name & "' );"
                    DoCmd.RunSQL StrSQL
                End If
            Next
        
        'Disposing of Objects
        Set fld = Nothing
        rs1.Close
        
        'Creating Array to iterate the import proces
        Set rstData = CurrentDb.OpenRecordset("Select CN FROM tblNames Order By CN ASC")
        rstData.MoveLast
        rstData.MoveFirst
        v = rstData.GetRows(rstData.RecordCount)
        For Each cn In v
           
            'Dropping Query If Exists
            On Error Resume Next
            CurrentDb.QueryDefs.Delete "CCBS"
        
            'Creating New Query For Next 
            Set qdf = db.CreateQueryDef("CCBS")
            
            qdf.SQL = "SELECT [Help].[Soldier Number], [Help].[" & CStr(cn) & "] FROM Help WHERE ((([Help].[" & CStr(cn) & "]) >= '1')) ORDER BY [Help].[Soldier Number];"
        
            Set qdf = Nothing
            
            'Building out the Insert Query String
            AppendSQL = "INSERT INTO ProdTable ( QTY, CIDItem, ICC, ItemName, location ) SELECT [CCBS].[" & CStr(cn) & "], CC.CustomerID, [tblNames].[CN], TIN.Description, CC.locationtype FROM CCBS INNER JOIN CC ON [CCBS].[Store Number] = CC.locationationNumber, tblNames INNER JOIN TIN ON [tblNames].CN = TIN.ItemID WHERE [tblNames].CN = '" & CStr(cn) & "';"
            
            'Executing the Append Query String
            db.Execute AppendSQL, dbFailOnError
            
        Next
        
        Set db = Nothing
        
    Next
    Else
        'Messagebox to show that the user clicked out of the import box
        MsgBox "You clicked Cancel in the file dialog box."
    End If
    
End With


'Final Cleanup before turning control back over
DoCmd.SetWarnings True
On Error Resume Next
CurrentDb.QueryDefs.Delete "CCBS"
On Error Resume Next
CurrentDb.TableDefs.Delete "Help"
On Error Resume Next
CurrentDb.TableDefs.Delete "Help1"


End Sub

[ranman256]

Instead of using a recordset,use a Tabledef.
but why spend so much time on coding this when you could do it faster manually?

[Micron]

Agree - seems strange, but then maybe it's a learning thing.
You can't expect to enumerate through a field collection by vaguely specifying a loop when the collection has/needs a specific ordinal position type of property. In other words, get the count of the fields (i) and loop via rs.fields(i). Can't recall at the moment if the fields collection is zero based or not.

Also, from a quick glance it appears you're closing record sets but are not releasing the memory allocated to them. Set them to Nothing as well.

[jo15765]

How would I use a Tabledef to do such?

In this instance it would not be quicker to do it manually. I am manually allowing a user to select a spreadsheet and manipulating elements of that spreadsheet that import as number to text so that joins and data work properly.

[jo15765]

Also, from a quick glance it appears you're closing record sets but are not releasing the memory allocated to them. Set them to Nothing as well.

Very good point! I had not even realized that. I can upload a sample database with spreadsheet to illustrate what I am doing if that would benefit and give a better understanding.

[Micron]

can you prefix all the spreadsheet data to be imported as text with a single quote? That should enforce it to be transferred as text.

[John_G]

You have StrSQL = "select fieldname from Help1"
So this statement: Set rs3 = db.OpenRecordset(StrSQL)
opens the table Help1 into recordset rs3, retrieving only one field (fieldname) from each record.

However, these 4 lines:

            For Each fld In rs3.Fields
            
                secondSQL = "ALTER TABLE Help ALTER COLUMN [" & fld.Value & "] TEXT(40);"
                DoCmd.RunSQL secondSQL
                
            Next

are not stepping through each record in rs3. Instead, they step through each field of the first record of rs3 (and there is only one field)

I think what you want is something like this:

 
           while not rs3.eof
            
                secondSQL = "ALTER TABLE Help ALTER COLUMN [" & rs3!fieldname & "] TEXT(40);"
                DoCmd.RunSQL secondSQL
                rs3.movenext
            Wend

[jo15765]

@John_G - that was it! Thank you for the assistance!