Upload data from excel file to access table using vba

[aman1234]

Hi guys

I have designed a userform where we can browse a file when the user clicks on Browse button and that file name appears in the textbox as below:

Private Sub CommandButton1_Click()
Dim fn
fn = Application.GetOpenFilename 
If fn = False Then
    MsgBox "Nothing Chosen"
Else
    MsgBox "You chose " & fn
    TextBox1.Value = fn
    End If
End Sub

Now there is one upload button also and when the user click on this button then it should upload data from excel file to Access table. Access table has all the fields that are present in Excel file that we browse using the above code. Can anyone please help me to write code for this please. See attached an example of excel file that the user will browse evrytime .

Thanks
Aman

[aman1234]

Can anyone please figure out my problem? Many Thanks

[aman1234]

Hi guys

Can anyone please point me in the right direction? How can I upload a excelsheet data in Access table using excel/vba.

Thanks

[mike7952]

This will give you some idea

Option Explicit
Sub uploadData()
 Const adStateOpen As Long = 1
 Const adOpenStatic As Long = 3
 Const adLockOptimistic As Long = 3
 Dim oCnn As Object
 Dim oRs As Object
 Dim sSQL As String, sCnn As String
 Dim ptr As Long
 
    ' Connection string, Change Data Source=C:\mydatabase.mdb to your needs
    ' Works for access 2003. If you have access 2007 or higher use
    ' Microsoft.ACE.OLEDB.12.0 and .accdb
    sCnn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\mydatabase.mdb"
    
    ' Create Connection Object
    Set oCnn = CreateObject("ADODB.Connection")
    ' Open Created Connection
    On Error Resume Next
    oCnn.Open sCnn
    ' Check Connection State.
    If oCnn.State <> adStateOpen Then
        MsgBox "File Not found: " & vbCrLf & oCnn.ConnectionString, vbCritical
        Exit Sub
    End If
    On Error GoTo 0
    
'   Your Table
    sSQL = "TableName"

    Set oRs = CreateObject("ADODB.Recordset")
    
    ' Open Created Recordset
    On Error Resume Next
    oRs.Open sSQL, oCnn, adOpenStatic, adLockOptimistic
    If oRs.State <> adStateOpen Then
        MsgBox "Could not table: " & sSQL, vbCritical
        oCnn.Close
        Set oCnn = Nothing
        Exit Sub
    End If
    On Error GoTo 0
    
    For ptr = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        With oRs
            .AddNew
            ' Change FielName to you Table field names.
            ' Add more fields to suit your needs
            .Fields("FieldName1") = Range("A" & ptr)
            .Fields("FieldName2") = Range("B" & ptr)
            .Update
        End With
    Next ptr
    ' Close Recordset
    oRs.Close
    Set oRs = Nothing
    ' Close Connecton
    oCnn.Close
    Set oCnn = Nothing
    
End Sub

[aman1234]

Hi Mike

Thanks for your reply. But there is one confusrion here. As I have to write code in excel/vba that will upload data from sheet1 of another excel file to the Access table. The path and name of another excel file is present in textbox1 as mentioned in the code in the above post.

I hope you can change the code accordingly.

Thanks a lot.

[aman1234]

Hi

The following code works fine. But the only thing is it uploads data from sheet3 of present workbook to Access table. But in actual I want a functionality so that the user first browse the excel file and when he clicks on Upload button then it should upload that excel file to Access table. I have written the code to browse an escel file but how can we upload that file to Access table?

Private Sub CommandButton2_Click()
Call ExcelToAccess
End Sub
Sub ExcelToAccess()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset

Dim r As Long
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
        "Data Source=C:\aa.mdb"
      Set rs = CreateObject("ADODB.Recordset")
    rs.Open "tblmain", cn, adOpenKeyset, adLockOptimistic, adCmdTable
        
    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets("sheet3")
    r = 3 ' the start row in the worksheet
    Do While Len(Range("A" & r).Formula) > 0
    ' repeat until first empty cell in column A
        With rs
            .AddNew ' create a new record
            ' add values to each field in the record
            .Fields("dgbID") = ws1.Range("A" & r).Value
            .Fields("Title") = ws1.Range("B" & r).Value
            .Fields("Fname") = ws1.Range("C" & r).Value
            .Fields("Surname") = ws1.Range("D" & r).Value
             .Fields("Add1") = ws1.Range("E" & r).Value
              .Fields("Add2") = ws1.Range("F" & r).Value
               .Fields("Add3") = ws1.Range("G" & r).Value
                .Fields("Add4") = ws1.Range("H" & r).Value
                 .Fields("Add5") = ws1.Range("I" & r).Value
                  .Fields("Add6") = ws1.Range("J" & r).Value
                   .Fields("Pcode") = ws1.Range("K" & r).Value
                    .Fields("campcode") = ws1.Range("L" & r).Value
                    .Fields("URN") = ws1.Range("A" & r).Value & "_" & ws1.Range("L" & r).Value
            .Update ' stores the new record
        End With
        r = r + 1 ' next row
    Loop
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub

[mike7952]

Try this

Option Explicit

Private Sub uploadData()

 Dim oCnn As ADODB.Connection
 Dim oRs As ADODB.Recordset
 Dim sSQL As String, sCnn As String
 Dim rsRow As Long, rsCol As Long
 Dim aData As Variant
 
    ' Connection string, Change Data Source=C:\mydatabase.mdb to your needs
    ' Works for access 2003. If you have access 2007 or higher use
    ' Microsoft.ACE.OLEDB.12.0 and .accdb
    sCnn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Users\Mike\Desktop\db1.mdb"
    
    ' Create Connection Object
    Set oCnn = New ADODB.Connection
    ' Open Created Connection
    On Error Resume Next
    oCnn.Open sCnn
    ' Check Connection State.
    If oCnn.State <> adStateOpen Then
        MsgBox "File Not found: " & vbCrLf & oCnn.ConnectionString, vbCritical
        Exit Sub
    End If
    On Error GoTo 0
    
'   Your Table
    sSQL = "tblmain"

    Set oRs = New ADODB.Recordset
    ' Open Created Recordset
    On Error Resume Next
    oRs.Open sSQL, oCnn, adOpenStatic, adLockOptimistic
    If oRs.State <> adStateOpen Then
        MsgBox "Could not table: " & sSQL, vbCritical
        oCnn.Close
        Set oCnn = Nothing
        Exit Sub
    End If
    On Error GoTo 0
    
    
'   Call to get data from excel sheet.
'   Param 1 Path
'   Param 2 File Name
'   Param 3 Sheet name
    aData = GetExcelData("C:\Users\Mike\Desktop\", "Example dummy data ", "Orphans")
    
    For rsRow = LBound(aData, 2) To UBound(aData, 2)
        With oRs
            .AddNew
            .Fields("dbgID") = aData(0, rsRow)
            .Fields("Title") = aData(1, rsRow)
            .Fields("First name") = aData(2, rsRow)
            .Fields("Surname") = aData(3, rsRow)
            .Fields("Address 1") = aData(4, rsRow)
            .Fields("Address 2") = aData(5, rsRow)
            .Fields("Address 3") = aData(6, rsRow)
            .Fields("Address  4") = aData(7, rsRow)
            .Fields("Address 5") = aData(8, rsRow)
            .Fields("Address 6") = aData(9, rsRow)
            .Fields("Postcode") = aData(10, rsRow)
            .Fields("Campaign code") = aData(0, rsRow) & "_" & aData(11, rsRow)
            .Update
        End With
    Next

    ' Close Recordset
    oRs.Close
    Set oRs = Nothing
    ' Close Connecton
    oCnn.Close
    Set oCnn = Nothing
    
End Sub

 Public Function GetExcelData(sPath As String, sFileName As String, sSheetName As String) As Variant
    
    Dim sCnn As String
    sCnn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sPath & sFileName & ".xls;Extended Properties=""Excel 8.0;HDR=Yes"""
    
    Dim oCnn As ADODB.Connection
    Set oCnn = New ADODB.Connection
    oCnn.Open sCnn
    
    Dim sSQL As String
    sSQL = "SELECT * FROM [" & sSheetName & "$]"
    Dim oRs As ADODB.Recordset
    Set oRs = New ADODB.Recordset
    With oRs
        .Open sSQL, oCnn
            If Not .EOF Then
                GetExcelData = .GetRows
            End If
        .Close
    End With
    Set oRs = Nothing
    
    oCnn.Close
    Set oCnn = Nothing

End Function

[aman1234]

Thanks Mike

I tried the following code but its giving me runtime error : The Microsoft Jet database engine could not find the object 'Orpkans'. Make sure the object exists and you spell its name and path correctly.

Private Sub CommandButton1_Click()
Dim fn
fn = Application.GetOpenFilename
If fn = False Then
    MsgBox "Nothing Chosen"
Else
    MsgBox "You chose " & fn
    TextBox1.Value = fn
End If
End Sub

Private Sub CommandButton2_Click()
'Call ExcelToAccess
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset

Dim r As Long
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
        "Data Source=C:\Documents and Settings\Amanpreet Kaur\Desktop\ResponseHandling.mdb"
      Set rs = CreateObject("ADODB.Recordset")
    rs.Open "tblmain", cn, adOpenKeyset, adLockOptimistic, adCmdTable
        
aData = GetExcelData(TextBox1.Value, "Orphans")
    
    For rsRow = LBound(aData, 2) To UBound(aData, 2)
        With oRs
            .AddNew
            .Fields("dbgID") = aData(0, rsRow)
            .Fields("Title") = aData(1, rsRow)
            .Fields("First name") = aData(2, rsRow)
            .Fields("Surname") = aData(3, rsRow)
            .Fields("Address 1") = aData(4, rsRow)
            .Fields("Address 2") = aData(5, rsRow)
            .Fields("Address 3") = aData(6, rsRow)
            .Fields("Address  4") = aData(7, rsRow)
            .Fields("Address 5") = aData(8, rsRow)
            .Fields("Address 6") = aData(9, rsRow)
            .Fields("Postcode") = aData(10, rsRow)
            .Fields("Campaign code") = aData(0, rsRow) & "_" & aData(11, rsRow)
            .Update
        End With
    Next
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub
Public Function GetExcelData(sPath As String, sSheetName As String) As Variant
    
    MsgBox sPath
    MsgBox sSheetName
    'Exit Function
    Dim sCnn As String
    sCnn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sPath & ".xls;Extended Properties=""Excel 8.0;HDR=Yes"""
    
    Dim oCnn As ADODB.Connection
    Set oCnn = New ADODB.Connection
    oCnn.Open sCnn
    
    Dim sSQL As String
    sSQL = "SELECT * FROM [" & sSheetName & "]"
    Dim oRs As ADODB.Recordset
    Set oRs = New ADODB.Recordset
    With oRs
        .Open sSQL, oCnn
            If Not .EOF Then
                GetExcelData = .GetRows
            End If
        .Close
    End With
    Set oRs = Nothing
    
    oCnn.Close
    Set oCnn = Nothing

End Function

[mike7952]

You need to change GetExcelData("C:\Users\Mike\Desktop\", "Example dummy data ", "Orphans"). Also I see your Access table field names are different then what I posted. will need to change that part of code as well.

'   Call to get data from excel sheet.
'   Param 1 Path
'   Param 2 File Name
'   Param 3 Sheet name
    aData = GetExcelData("C:\Users\Mike\Desktop\", "Example dummy data ", "Orphans")

---------- Post added at 08:03 AM ---------- Previous post was at 07:57 AM ----------

Orphans needs to be changed to your Sheet Name in Excel file.

[aman1234]

Mike,

The textbox1 stores both path and filename. So thats why I am using the follwoing line:

aData = GetExcelData(TextBox1.Value, "Orphans")

Public Function GetExcelData(sPath As String, sSheetName As String) As Variant
    
    
    Dim sCnn As String
    sCnn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sPath & ";Extended Properties=""Excel 8.0;HDR=Yes"""
    
    Dim oCnn As ADODB.Connection
    Set oCnn = New ADODB.Connection
    oCnn.Open sCnn
    
    Dim sSQL As String
    sSQL = "SELECT * FROM [" & sSheetName & "]"
    Dim oRs As ADODB.Recordset
    Set oRs = New ADODB.Recordset
    With oRs
        .Open sSQL, oCnn
            If Not .EOF Then
                GetExcelData = .GetRows
            End If
        .Close
    End With
    Set oRs = Nothing
    
    oCnn.Close
    Set oCnn = Nothing

End Function

The sheet name will be "Orphans" always. Can you tell me why the error message is coming if I change the code as above.

Thanks

[mike7952]

Must have a $ after sheet name

sSQL = "SELECT * FROM [" & sSheetName & "$]"

[aman1234]

Thanks a lot Mike. Its working absolutely fine. U r Gr8.