excel to access data transfer

[xljdg]

I got this code and it is very useful for my project.

Sub ToAccess()
Dim axsApp As Object
'Assume Access already open with desired database
Set axsApp = GetObject(, "Access.Application")
Set cdb = axsApp.currentdb
Set rst = cdb.openrecordset("Employees")
Dim iRow As Long 'Excel worksheet row number
'Loop thru first 8 rows on active worksheet and put data from
'first two columns into Access employees table
For iRow = 1 To 8
With rst
.addnew
' read the names from Excel into Access table
!LastName = Cells(iRow, 2)
!FirstName = Cells(iRow, 1)
.Update
End With
Next iRow
End Sub

This code works only if the database is open can this work if the database is closed on the network.

any help will be greately appreciated.

 

[Case_Germany]

Hi,

you could take a file selection dialog:

Option Explicit
Dim blnTMP As Boolean
Public Sub Main()
    Dim rcsEntry As Object
    Dim strPath  As String
    Dim objConn As Object
    Dim objApp As Object
    Dim lngRow As Long
    On Error GoTo Fin
    If fncFile(strPath) <> "" Then
        'Set objApp = OffApp("Word")
        'Set objApp = OffApp("Word", False)
        'Set objApp = OffApp("Outlook")
        'Set objApp = OffApp("Outlook", False)
        'Set objApp = OffApp("PowerPoint")
        'Set objApp = OffApp("PowerPoint, False")
        'Set objApp = OffApp("ACCESS")
        Set objApp = OffApp("ACCESS", False)
        If Not objApp Is Nothing Then
            Set rcsEntry = CreateObject("ADODB.Recordset")
            Set objConn = CreateObject("ADODB.Connection")
            With objConn
                .CursorLocation = 3 ' = adUseClient
                If Val(Application.Version) >= 12 Then
                    .Provider = "Microsoft.ACE.OLEDB.12.0"
                Else
                    .Provider = "Microsoft.Jet.OLEDB.4.0"
                End If
                .Properties("Data Source") = strPath
                .Open
            End With
            With rcsEntry
                .Open "Select * from Employees", objConn, 1, 3
                For lngRow = 1 To 14
                    .addnew
                    !LastName = Cells(lngRow, 2)
                    !FirstName = Cells(lngRow, 1)
                    .Update
                Next lngRow
            End With
        Else
            MsgBox "Application not installed!"
        End If
    Else
        MsgBox "No file selected!"
    End If
Fin:
    If Not objApp Is Nothing Then
        If blnTMP = True Then
            objApp.Quit
            blnTMP = False
        End If
    End If
    Set objApp = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            blnTMP = True
            If blnVisible = True Then
                On Error Resume Next
                objApp.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function
Private Function fncFile(strTMP As String) As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = "C:\" ' adapt
        .Title = "File Selection"
        .ButtonName = "Select..."
        .InitialView = msoFileDialogViewDetails
        ' With all file types
        '.Filters.Add "Database", "*.mdb; *.accdb; *.*", 1
        .Filters.Add "Database", "*.mdb; *.accdb", 1
        '.FilterIndex = 1
        If .Show = -1 Then
            strTMP = .SelectedItems(1)
        Else
            fncFile = ""
        End If
    End With
    fncFile = strTMP
End Function

 

[xljdg]

That is exacly what i requried. That code was really helpful . Thank you for helping me out here