PDA

View Full Version : [SOLVED] Sending Excel range to Access; question...



title_bu
08-02-2010, 12:42 PM
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
08-02-2010, 07:01 PM
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
08-03-2010, 06:26 AM
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
08-03-2010, 08:15 AM
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