Copy From Excel To Access

[DMT Dave]

Hi Guy's, i am struggling with the correct method to do the following:



Copy Excel cells that are pasted in to row 6 (always the case), there could be 20 records or 40 records (quantity can vary)

Add The amount of records to recordset:

If there are 27 rows copied (from row 6), count the rows copied (row 6 to xlEndRow) and add the amount of records to a recordset

Add the data to the same field names in access: this what i have so far:

Dim stAppName As String, myURL As String, OpenChrome As String, myApp As StringDim stPathName As String
Dim xlRow As Long, LastRow As Long, ColCount As Long
Dim myRow As Integer, c1 As String, c2 As String, c3 As String, c4 As String, c5 As String, c6 As Integer, c7 As Integer, c8 As String
Dim FindRow As Range, i As Integer
Dim xl As Excel.Application
Dim xlsht As Excel.Worksheet
Dim xlWrkBk As Excel.Workbook
Dim myCust As String, cAdd1 As String, cAdd2 As String, cTown As String, cPC As String


SrcPath = "T:\DMT Ltd\XL Files\"
SrcFile = "New Items.xlsx"

'IMPORTANT TO KNOW, 'AN EXTAERNAL CLOUD BASED FILE OPENS BEFORE THIS PROCEDURE TO COPY CELLS FROM

If MsgBox("Have You Copied Your Records From Source File?", vbQuestion + vbYesNo, "PASTED") = vbNo Then
DoCmd.CancelEvent
Else
myCust = Forms!frmMainMenu!frmIndex1!cboCustomer
cAdd1 = DLookup("Add1", "tblCustomers", "[Name] Like ""*" & myCust & "*""")
cAdd2 = DLookup("Add2", "tblCustomers", "[Name] Like ""*" & myCust & "*""")
cTown = DLookup("Town", "tblCustomers", "[Name] Like ""*" & myCust & "*""")
cPC = DLookup("Postcode", "tblCustomers", "[Name] Like ""*" & myCust & "*""")




Set xl = CreateObject("Excel.Application")
Set xlWrkBk = GetObject(SrcPath & SrcFile)
Set xlsht = xlWrkBk.Worksheets(1)
LastRow = xlsht.UsedRange.Rows.Count
ColCount = xlsht.UsedRange.Columns.Count
myRow = "6"
For i = 0 To myRow
c1 = xlsht.Cells(i, 2).Value ' Del TO
c2 = xlsht.Cells(i, 3).Value 'Town
c3 = xlsht.Cells(i, 4).Value 'PostCode
c4 = xlsht.Cells(i, 5).Value 'ItemNo
c5 = xlsht.Cells(i, 6).Value 'SL
c6 = xlsht.Cells(i, 7).Value 'Boxes
c7 = xlsht.Cells(i, 8).Value 'Rails
Next i
Set rs = CurrentDb.OpenRecordset("Select * From tblEdit")
With rs
.AddNew
!Customer = myCust
!CustAdd1 = cAdd1
!CustAdd2 = cAdd2
!CustTown = cTown
!CustPostCode = cPC
!ShipmentDate = Null
!PONumber = "PO-"
!SONumber = c5
!LiftType = "Item"
!LiftNo = c4
!TotalBox = c6
!TotalRail = c7
!DelTo = c1
!Town = c2
!PostCode = c3
!Added = "New"
!Status = "Planning"
!DueDay = ""
!Source = "Acc"
.Update
.Close
End With
xl.Quit
Set xl = Nothing
Set xlWrkBk = Nothing
End If

[Micron]

You didn't say if there was an issue. Would rather know that than read the code to try and guess.

EDIT - TBH, if you don't properly indent your code you will likely reduce feedback eventually. Not only does it make it harder to trouble shoot, it will sometimes hide the problem that you might otherwise find all by yourself.

My guess is that you're only adding values from the last row to the recordset.

[Welshgasman]

Again, walk through your code, line by line.
You say you want rows 6 to 27, yet your count is 0 to 6, and as Micron states, the last row is 6, plus you make that index a string???

[ranman256]

wouldn't it be simpler to run an import, rather than write code?

[Welshgasman]

Also look at https://www.google.com/search?q=tran...obile&ie=UTF-8

[Micron]

wouldn't it be simpler to run an import, rather than write code?

Good question.

DMTDave, see if this highlights your issue. I may forget and indent your code in the future but don't count on it . That and stepping through are the 2 most important things you can do to spot a problem. Hopefully that advice will stick.

The SET for rs is extra-indented to show where I think it should be. Other lines I rem'd out so you'd spot the ones that I moved. Untested of course. Sometimes I also group my types, especially when it's a multi line declaration. Put them back as you wish. Just thinking that if I know something should be an integer I don't have to scan a paragraph of Dim statements to find a nested integer declaration. It's in its own group.

Dim stAppName As String, myURL As String, OpenChrome As String, myApp As StringDim stPathName As String
Dim myCust As String, cAdd1 As String, cAdd2 As String, cTown As String, cPC As String
Dim c1 As String, c2 As String, c3 As String, c4 As String, c5 As String, c8 As String
Dim xlRow As Long, LastRow As Long, ColCount As Long
Dim myRow As Integer, i As Integer, c6 As Integer, c7 As Integer,
Dim FindRow As Range
Dim xl As Excel.Application
Dim xlsht As Excel.Worksheet
Dim xlWrkBk As Excel.Workbook

SrcPath = "T:\DMT Ltd\XL Files\"
SrcFile = "New Items.xlsx"

'IMPORTANT TO KNOW, 'AN EXTAERNAL CLOUD BASED FILE OPENS BEFORE THIS PROCEDURE TO COPY CELLS FROM

If MsgBox("Have You Copied Your Records From Source File?", vbQuestion + vbYesNo, "PASTED") = vbNo Then
    DoCmd.CancelEvent
Else
    myCust = Forms!frmMainMenu!frmIndex1!cboCustomer
    cAdd1 = DLookup("Add1", "tblCustomers", "[Name] Like ""*" & myCust & "*""")
    cAdd2 = DLookup("Add2", "tblCustomers", "[Name] Like ""*" & myCust & "*""")
    cTown = DLookup("Town", "tblCustomers", "[Name] Like ""*" & myCust & "*""")
    cPC = DLookup("Postcode", "tblCustomers", "[Name] Like ""*" & myCust & "*""")

    Set xl = CreateObject("Excel.Application")
    Set xlWrkBk = GetObject(SrcPath & SrcFile)
    Set xlsht = xlWrkBk.Worksheets(1)
    
        Set rs = CurrentDb.openrecordset("SELECT * FROM tblEdit WHERE 1 = 0")'you don't use these values so load an empty recordset on the table
        
    LastRow = xlsht.UsedRange.Rows.Count
    ColCount = xlsht.UsedRange.Columns.Count
    myRow = "6"
    For i = myRow To LastRow
        c1 = xlsht.Cells(i, 2).Value ' Del TO
        c2 = xlsht.Cells(i, 3).Value 'Town
        c3 = xlsht.Cells(i, 4).Value 'PostCode
        c4 = xlsht.Cells(i, 5).Value 'ItemNo
        c5 = xlsht.Cells(i, 6).Value 'SL
        c6 = xlsht.Cells(i, 7).Value 'Boxes
        c7 = xlsht.Cells(i, 8).Value 'Rails
    ''Next i
    ''Set rs = CurrentDb.OpenRecordset("Select * From tblEdit") 'don't repeatedly open the same rs in a loop
    
        With rs
            .AddNew
            !Customer = myCust
            !CustAdd1 = cAdd1
            !CustAdd2 = cAdd2
            !CustTown = cTown
            !CustPostCode = cPC
            !ShipmentDate = Null
            !PONumber = "PO-"
            !SONumber = c5
            !LiftType = "Item"
            !LiftNo = c4
            !TotalBox = c6
            !TotalRail = c7
            !DelTo = c1
            !Town = c2
            !PostCode = c3
            !Added = "New"
            !Status = "Planning"
            !DueDay = ""
            !Source = "Acc"
            .Update
            ''.Close
        End With
    Next i
    
    rs.Close
    
    xl.Quit
    Set xl = Nothing
    Set xlWrkBk = Nothing
    Set xlsht = Nothing 'forgot this one. Such omissions are a byproduct of not indenting IMO
    
End If

[moke123]

I'm curious where your calling this from. What event?
Is it a cancelable event? if not DoCmd.CancelEvent means nothing.

[DMT Dave]

Hi Guy's thank you for your feedback, yes i must remember to indent code, any new code that I attempt i am indenting but when i have copied, pasted and tweaked original code taken from another db on our system, i just forget to, sorry but but will endeavour to remember..

Will look through all of your comments, sample codes

one answer to all commented is

A Customer will paste any quantity of records to a one drive Excel sheet

So my intention is to have a template (srcFile) to open

There are headers on the srcFile and in Cell B6 it says PASTE HERE

See image:


The next image although i have taken correct data out, is from the one drive



So the target is to copy used cells from one drive

Paste from cell B6

Count rows pasted

add that amount of records to db

Then save the data in the fields accordingly

IN my post, i Have used c2, 3,4 ,5 7,8 as string apart from 2 integers (c6 and c7) are a whole number

I will look at what micron has posted and have a play around

Thank you again guy's all is appreciated, like mentioned, i will endeavour to remember to indent codes as I can see its easier to identify functions etc.....

[DMT Dave]

Is ranmans suggestion an easy option also ? if so, i have never used import option ?

Will test micron's example though

[DMT Dave]

Also guy's, is testing if Len Of Dir better than this ???

Dim OpenChrome As String

If Left(Me.txtEnviron, 2) = "DM" Then
    OpenChrome = """C:\Program Files\Google\Chrome\Application\chrome.exe"""
    Else
    OpenChrome = """C:\Program Files (x86)\Google\Chrome\Application\chrome.exe"""
End If

Also from some strange reason, it won't work without 3 quotes, unsure why but 3 quotes works!!!!!!!!!!!!!!

[DMT Dave]

Hi Guy's WOW you are genius's on here, so so so so close to being perfect

copied Microns code, tested by pasting 4 records from one drive sheet into row 6, so row 6,7,8,9 are used on my SrcFile (Source File)

there are 2 issues

1: the recordset has added 38 blank records (Not 4)

2: there is no data in the fields apart from Item

Once i can get the 4 records to transfer, i guess my next target is to remove the data from the srcfile starting from row6 and replace with PASTE HERE

I am more intrigued to get the 4 records to the rs fields (Not 38 blanks)

Any ideas ????

[DMT Dave]

All solved guy's once again, thank you so so much, i got rid of blanks by setting another recordset to delete blank records, this all now does it as below, Added a new form to separate pasted records Pasted and added a field called Pasted Yes/No and set the criteria to Yes

Added !pasted in the recordset, deleted any blanks using rsDel and all perfect

Dim stAppName As String, myURL As String, OpenChrome As String, myApp As String, stPathName As StringDim myCust As String, cAdd1 As String, cAdd2 As String, cTown As String, cPC As String
Dim c1 As String, c2 As String, c3 As String, c4 As String, c5 As String, c8 As String
Dim xlRow As Long, LastRow As Long, ColCount As Long
Dim myRow As Integer, i As Integer, c6 As Integer, c7 As Integer, DelQty As Integer
Dim FindRow As Range
Dim xl As Excel.Application
Dim xlsht As Excel.Worksheet
Dim xlWrkBk As Excel.Workbook
Dim rsDel As DAO.Recordset


srcPath = "T:\DMT Ltd\XL Files\"
srcFile = "New Items.xlsx"






'IMPORTANT TO KNOW, 'AN EXTAERNAL CLOUD BASED FILE OPENS BEFORE THIS PROCEDURE TO COPY CELLS FROM


    myCust = Forms!frmMainMenu!frmIndex1!cboCustomer
    cAdd1 = DLookup("Add1", "tblCustomers", "[Name] Like ""*" & myCust & "*""")
    cAdd2 = DLookup("Add2", "tblCustomers", "[Name] Like ""*" & myCust & "*""")
    cTown = DLookup("Town", "tblCustomers", "[Name] Like ""*" & myCust & "*""")
    cPC = DLookup("Postcode", "tblCustomers", "[Name] Like ""*" & myCust & "*""")


    Set xl = CreateObject("Excel.Application")
    Set xlWrkBk = GetObject(srcPath & srcFile)
    Set xlsht = xlWrkBk.Worksheets(1)
    xl.Visible = False
    
        Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblEdit WHERE 1 = 0") 'you don't use these values so load an empty recordset on the table
        'Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblEdit")
        
    LastRow = xlsht.UsedRange.Rows.Count
   ' ColCount = xlsht.UsedRange.Columns.Count
    myRow = "6"
    For i = myRow To LastRow
        c1 = xlsht.Cells(i, 2).Value ' Del TO
        c2 = xlsht.Cells(i, 3).Value 'Town
        c3 = xlsht.Cells(i, 4).Value 'PostCode
        c4 = xlsht.Cells(i, 5).Value 'ItemNo
        c5 = xlsht.Cells(i, 6).Value 'SL
        c6 = xlsht.Cells(i, 7).Value 'Boxes
        c7 = xlsht.Cells(i, 8).Value 'Rails
    ''Next i
    ''Set rs = CurrentDb.OpenRecordset("Select * From tblEdit") 'don't repeatedly open the same rs in a loop
    
        With rs
            .AddNew
            !Customer = myCust
            !CustAdd1 = cAdd1
            !CustAdd2 = cAdd2
            !CustTown = cTown
            !CustPostCode = cPC
            !ShipmentDate = Null
            !PONumber = "PO-"
            !SONumber = c5
            !LiftType = "Item"
            !LiftNo = c4
            !TotalBox = c6
            !TotalRail = c7
            !DelTo = DLookup("Name", "tblDealers", "[PostCode] = '" & c3 & "'")
            !Town = DLookup("Town", "tblDealers", "[PostCode] = '" & c3 & "'")
            !PostCode = c3
            !Added = "New"
            !Status = "Planning"
            !DueDay = ""
            !Source = "Acc"
            !Pasted = True
            .Update
            ''.Close
        End With
    Next i
    rs.Close
    
    xl.Quit
    Set xl = Nothing
    Set xlWrkBk = Nothing
    Set xlsht = Nothing 'forgot this one. Such omissions are a byproduct of not indenting IMO
    
    Set rsDel = CurrentDb.OpenRecordset("Select * From tblEdit WHERE DelTo Is Null")
    DelQty = rsDel.RecordCount
    With rsDel
    Do Until rsDel.EOF
    .Delete
    rsDel.MoveNext
    Loop
    rsDel.Close
    End With
    Set rsDel = Nothing
    
    Me.frmIndex1DS.Visible = False
    Me.frmIndex1DSPaste.Visible = True
    Me.frmIndex1DSPaste.Requery

[Welshgasman]

Google Smart Indenter

[Welshgasman]

You need to check what your last line is?
Sometimes Excel thinks a row is being used, when it is blank.

[moke123]

Is ranmans suggestion an easy option also ? if so, i have never used import option ?

Will test micron's example though

Did you look at Gasman's link? It's related to RanMans.

Here it is again https://docs.microsoft.com/en-us/off...ferspreadsheet