Hai,
    Please help us regarding this query, we are new to Excel VBA programming.

    How to transfer the selected fields data present in Excel sheet to a table in Access database. We have various columns in Excel sheet but we need only selected columns to be stored in Access database. Could anybody help us as soon as possible.

Regards,
Swaroop.

How are you doing this transfer? Is it only once? Or do you want them to be permanently connected?

mmcdonal

yes we want them to be permanently connected.

our requirement is data will be coming to the excel sheet in online and we have to store the selected columns data in database.
First we got 10 details, we have to store them in database and after if another two records comes into the sheet we have to move that two records only in to the database.
please give reply .......

Regards,
swaroop.

 yes we want them to be permanently connected.

our requirement is data will be coming to the excel sheet in online and we have to store the selected columns data in database.
First we got 10 details, we have to store them in database and after if another two records comes into the sheet we have to move that two records only in to the database.
please give reply .......

Regards,
swaroop.

I am not sure why you are storing this data in an Excel spreadsheet. If they are permanently connected, then no one can post data to the spreadsheet when the database is open. Perhaps you should transfer the data you need periodically instead.

mmcdonal

Option Compare Database
Option Explicit

Dim FileName As String

Private Sub CmdGetExcelFile_Click()
Dim fd As FileDialog, Criteria As String 'declare file directory varialble and Criteria as string

Set fd = Application.FileDialog(msoFileDialogOpen)
fd.Show

If fd.SelectedItems.count = 0 Then Exit Sub 'check if theres any file exist
    FileName = fd.SelectedItems(1)
    txtFileName = FileName


End Sub

Private Sub CmdImportExcel_Click()

    If IsNull(FileName) = True Or FileName = "" Then
        MsgBox "No file is selected please select valid excel sheet to import", vbInformation
        Exit Sub
    End If

On Error GoTo Err_CmdImportExcel_Click

Dim td As TableDef, db As Database, Criteria As String, r As New ADODB.Recordset, t As New ADODB.Recordset, c As New ADODB.Connection
Dim trancount As Integer

Set c = CurrentProject.Connection
Set db = CurrentDb
Set td = db.TableDefs("ImportTestData")

trancount = c.BeginTrans


'Debug.Print td.Connect
Criteria = "Excel 5.0;HDR=NO;IMEX=2;DATABASE=" & FileName
td.Connect = Criteria

'Open Imported Table
r.Open "ImportTestData", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
t.Open "TestData", CurrentProject.Connection, adOpenKeyset, adLockOptimistic

'Adding record into Access table BOMTestData
Do While Not r.EOF

    If Nz(r!f2, "") <> "" And Nz(r!f3, "") <> "" Then
      If r!f4 >= 1 Then
            t.AddNew
            t!SXID = r!f1
            t!PID = r!f2
            t!SubPID = r!f3
            t!Quantity = r!f4
            t!Date = Now()
            t!User = CUser()
            t.Update
      Else
            If MsgBox("Problem with importing Data continue importing on Line No:" & r!f1, vbYesNoCancel, "Error") <> vbYes Then
                GoTo Err_CmdImportExcel_Click
            End If
      End If

     Else

            'if all rows null then must be end of the row
            If IsNull(r!f1) And IsNull(r!f2) And IsNull(r!f3) And IsNull(r!f4) Then
                MsgBox "All Records Imported", vbInformation
                FileName = ""
                txtFileName = ""
                Exit Do

            'Showing Msg for Empty PID or SubPID
            ElseIf IsNull(r!f2) Or IsNull(r!f3) Then
                MsgBox "ProductID or Sub ProductID missing from Line No:" & r!f1 & vbCr & "Cannot import with missing item", vbCritical, "Error"
                FileName = ""
                txtFileName = ""

            'if no error found
            Else
                MsgBox "All Records Imported", vbInformation
                FileName = ""
                txtFileName = ""
            End If
        Exit Do

    End If
    r.movenext
Loop
c.CommitTrans
r.Close
t.Close

Exit_CmdImportExcel_Click:
Exit Sub

Err_CmdImportExcel_Click:

    MsgBox Err.Description
    c.RollbackTrans
    Resume Exit_CmdImportExcel_Click

End Sub