Sending Excel range to Access; question...

[title_bu]

Below is some code I put together because I just started this new job and they need a way to push quite a few spreadsheets into Access tables and this method will save me a whole lot of time.

My problem is that this will run, but it only uploads the first field into the database.

Public Sub SendToTable(Path as String, TableName as string)
Dim userSelection As String, rSel As String
Dim colLoc As Integer, strLen As Integer
Dim t As Integer, i As Integer, m As Integer
Dim selLet1 As String, selNum1 As Long, selNum2 As Long
Dim concatFields As String
Dim firstCell As String, selValue As String, colCount  As Integer
Dim barCount As Integer, selLetASCII As Integer, fieldName As String
Dim currLetter As String
Dim Db As Database, Rs As Recordset, r As Long, pathOverride As String
Dim Path As String, TableName As String '-----Temp will have to pass
m = 1
For m = 1 To 1
    userSelection = Replace(Selection.Address, "$", "")
    userResponse = MsgBox("Is " & userSelection & " the range of values that represent the field names of the table.", vbYesNo, "Select Range")
    If userResponse = "6" Then
    Else
        MsgBox "Please select the range and try again.", vbOKOnly, "Select Range"
        Exit For '------NOTHING will run after this point if "No" is selected."
    End If
    i = 1
    For i = 1 To 1
        rSel = userSelection
        colLoc = InStr(1, rSel, ":")
        strLen = Len(rSel)
        If colLoc = 0 Then
            t = 1 '----Determing the number of letters in location - C vs CC (etc)
            For t = 1 To 5
                If IsNumeric(Mid(rSel, t, 1)) Then Exit For
           Next t
           selLet1 = Left(rSel, t - 1)
           selNum1 = CInt(Right(rSel, strLen - t + 1))
           selNum2 = selNum1
      Else
           t = 1 '----Determing the number of letters in location - C vs CC (etc)
           For t = 1 To 5
              If IsNumeric(Mid(rSel, t, 1)) Then Exit For
          Next t
          selLet1 = Left(rSel, t - 1)
          selNum1 = CInt(Mid(rSel, t, colLoc - t))
          t = 1 '----Determing the number of letters in location - C vs CC (etc)
          For t = 1 To 5
              If IsNumeric(Mid(Right(rSel, strLen - colLoc), t, 1)) Then Exit For
              Next t
              selNum2 = CInt(Right(Right(rSel, strLen - colLoc), Len(Right(rSel, strLen - colLoc)) - Len(Left(Right(rSel, strLen - colLoc), t - 1))))
              If selNum1 <> selNum2 Then
                  MsgBox "The field name range can only be one row. Please try again.", vbCritical, "Error"
                 Exit For
             Else
             End If
        End If
        t = 1
        For t = 1 To CInt(Range(rSel).Count)
            'Sets a basepoint and moves one cell to the right per iteration using offset
            concatFields = concatFields & "|" & Trim(Range(selLet1 & selNum1).Offset(0, t - 1).Value)
        Next t
        selValue = concatFields & "|" '----Assigns the string value to the function for output
       'Debug.Print selValue
    Next i
Next m
If Right(Path, 4) <> ".mdb" Then
    Do While Right(Path, 4) <> ".mdb"
        pathOverride = InputBox("The file location is invalid. Override it below, using the demonstrated format.", "Override Path", "C:\Folder1\MyDatabase.mdb")
        Path = pathOverride
    Loop
Else
End If
Set Db = OpenDatabase(Path)
Set Rs = Db.OpenRecordset(TableName, dbOpenTable)
barCount = CharCount(selValue, "|", True)
selLetASCII = Asc(selLet1)
colCount = barCount - 1
i = selLetASCII
r = 2 ' the start row in the worksheet
For i = selLetASCII - 64 To selLetASCII - 64 + colCount - 1
    If Int(i / 26) = 0 Or i = 26 Then
        currLetter = DecodeASCII(CInt(i + 64)
    Else
        currLetter = DecodeASCII(Int(i / 26) + 64) & DecodeASCII((((i / 26) - Int(i / 26)) * 26) + 1 + 64)
    End If
    fieldName = Range(currLetter & selNum1).Value
    Do While Len(Range(selLet1 & r).Formula) > 0
        ' repeat until first empty cell in first column
        With Rs
            .AddNew ' create a new record
            ' add values to each field in the record
            .Fields(fieldName) = Range(currLetter & r).Value
            ' add more fields if necessary...
            .Update ' stores the new record
        End With
        r = r + 1 ' next row
    Loop
    'Debug.Print currLetter, fieldName
Next i
Rs.Close
Set Rs = Nothing
Db.Close
Set Db = Nothing
End Sub

The problem has to be with the final do/while loop, but I can't figure out what it is. When I debug for the currLetter and fieldName, the for loop is doing what I want it to do. Again, its only uploading the first column.

Any help would be greatly appreciated.

[Kenneth Hobs]

I am not sure what all you are trying to achieve.

This simple method is one that I have used. One could add a sheet and add the field name to row 1, name the range, and then play the macro.

Sub demo()
  Dim objRS As Object, nwindPath As String
  Set objRS = CreateObject("ADODB.Recordset")
  nwindPath = ThisWorkbook.Path & "\nwind.mdb"
Dim r As Range
  [a1] = "LastName"
  [b1] = "FirstName"
  [a2] = "Hobson"
  [b2] = "Kenneth"
  Set r = [a1:b2]
  r.Name = "MyRange"
objRS.Open "INSERT INTO Employees SELECT * FROM [MyRange] IN '" & ThisWorkbook.FullName & "' 'Excel 8.0;'", _
      "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & nwindPath
Set objRS = Nothing
End Sub

[title_bu]

Thank you. Itll need some tweeking, but that'll accomplish what Im trying to do.

Just an aside if you are sharing with others, ThisWorkbook.FullName may cause some issues. I've ran into it in the past so I knew right away why it didn't run at first, but if people have their modules docked on a hidden workbook that loads at excel startup (like I do) ThisWorkbook.FullName returns the path of the hidden workbook (so it wont be able to find the range in this case)

Again, though, thanks.

[title_bu]

Just closing this off, so anyone else can use it if they'd like. This should be universal in nature.

Public Sub UploadToAccess(dbPath As String, db_tblName As String, Optional workbookPath As String, Optional sheetName As String)
Dim objRS As Object, bookName As String
    Set objRS = CreateObject("ADODB.Recordset")
    Dim r As Range
If Len(sheetName) > 0 Then
    Sheets(sheetName).Select
        Else
        End If
If Len(workbookPath) > 0 Then
    workbookPath = workbookPath
        Else
    workbookPath = ThisWorkbook.FullName
        End If
SelectUsedRange '--User-defined procedure
Set r = Range(Selection.Address)
            'Set r = [a1:J5356]
r.Name = "MyRange"
objRS.Open "INSERT INTO " & db_tblName & " SELECT * FROM [MyRange] IN '" & workbookPath & "' 'Excel 8.0;'", _
            "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath
Set objRS = Nothing
End Sub

Sub SelectUsedRange()
' Find the FIRST real row
    firstRow = ActiveSheet.Cells.Find(What:="*", _
      SearchDirection:=xlNext, _
      SearchOrder:=xlByRows).Row
' Find the FIRST real column
    firstCol = ActiveSheet.Cells.Find(What:="*", _
      SearchDirection:=xlNext, _
      SearchOrder:=xlByColumns).Column
' Find the LAST real row
    lastRow = ActiveSheet.Cells.Find(What:="*", _
      SearchDirection:=xlPrevious, _
      SearchOrder:=xlByRows).Row
' Find the LAST real column
    LastCol = ActiveSheet.Cells.Find(What:="*", _
      SearchDirection:=xlPrevious, _
      SearchOrder:=xlByColumns).Column
'Select the ACTUAL Used Range as identified by the variables identified above
ActiveSheet.Range(Cells(firstRow, firstCol), Cells(lastRow, LastCol)).Select
End Sub