Updating Invoice Data to Access Database with VBA

Question

I have created a Sheet1(BILL FORMAT) in excel to save my records in a sheets like sheet3(ITEM DATA). But after few days working with this Sheet1(BILL FORMAT), it is now goes slower, because of heavy data saving in sheet3(ITEM DATA). Now I want to save all records to a Access database and want to keep clean my sheet3(ITEM DATA). So I can work on my Sheet1(BILL FORMAT) easily or without any delay. Also wants updates my record by calling it via serial numbers. but I don't want to keep any record in my sheet3(ITEM DATA).

Given below link is good for save invoice records. Because its saves records one by one row. PREVIOUS RELATED LINK

But now i also required save invoice Items Records.

My Little Code is mentioned below: -

    Sub SAVE_DATA()
  i = 1
  Do Until Sheets("ITEM DATA").Range("C" & i).Value = ""
    If Sheets("ITEM DATA").Range("C" & i).Value = Sheets("BILL FORMAT").Range("B1").Value Then
      'Ask overwrite invoice #?
      'If MsgBox("Overwrite invoice data?", vbYesNo) = vbNo Then
        Exit Sub
      Else
        Exit Do
      'End If
    End If
    i = i + 1
  Loop
  i = 1
  Set rng_dest = Sheets("ITEM DATA").Range("G:K")
  'Delete rows if invoice # is found
  Do Until Sheets("ITEM DATA").Range("C" & i).Value = ""
    If Sheets("ITEM DATA").Range("C" & i).Value = Sheets("BILL FORMAT").Range("B1").Value Then
      Sheets("ITEM DATA").Range("C" & i).EntireRow.Delete
      i = 1
    End If
    i = i + 1
  Loop

    Set rng_dest = Sheets("ITEM DATA").Range("G:K")
  ' Find first empty row in columns G:K on sheet ITEM DATA
  Do Until WorksheetFunction.CountA(rng_dest.Rows(i)) = 0
    i = i + 1
  Loop
  'Copy range A7:E11 on sheet BILL FORMAT to Variant array
  Set Rng = Sheets("BILL FORMAT").Range("A7:E11")

  ' Copy rows containing values to sheet ITEM DATA
  For a = 1 To Rng.Rows.Count
    If WorksheetFunction.CountA(Rng.Rows(a)) <> 0 Then
      rng_dest.Rows(i).Value = Rng.Rows(a).Value

      'Copy SR. NO.
      Sheets("ITEM DATA").Range("C" & i).Value = Sheets("BILL FORMAT").Range("B1").Value
      
      'Copy NAME
      Sheets("ITEM DATA").Range("D" & i).Value = Sheets("BILL FORMAT").Range("B2").Value
      
      'Copy LOCATION
      Sheets("ITEM DATA").Range("E" & i).Value = Sheets("BILL FORMAT").Range("B3").Value
      
      'Copy CONTACT
      Sheets("ITEM DATA").Range("F" & i).Value = Sheets("BILL FORMAT").Range("B4").Value

      i = i + 1
    End If
  Next a

Application.ScreenUpdating = False
On Error Resume Next
Sheet3.Columns("G:G").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True

Range("B1").Value = Range("B1").Value + 1
Range("B2:B4").ClearContents
Range("A7:D11").ClearContents

Range("B2").Select

End Sub

and i have no idea how to convert this sheet code to link with access database.

any help will be appreciated.

Do you want to retrieve records from the database back onto the sheet to update them ? How many lines on the sheet after a few days when you notice it slowing down ? When deleting rows it is better to work up the sheet, you seem to be repetitively scanning down the sheet on every delete. — CDP1802, Mar 01 '21 at 11:46
Thank You for your kind reply. **1)**- Actually sir, retrieve data from database is a another question. and I will ask that question later. **2)**- After working on this sheet (BILL FORMAT) for 2 to 3 months, about 3000 or 4000 rows are saved in (ITEM DATA SHEET), which makes it difficult to work later. So now I want to save all data to a access database. and want to my ITEM DATA SHEET clean. So if my Excel workbook today is 50 kb, then after a month or even after 10 months this workbook should remain 50 kb. And all item records must be saved in the access database. — Prabhat Vishwas, Mar 01 '21 at 12:16
What triggers the save and sheet clearance.? How do you want to resolve conflicts between the spreadsheet and the database For example where a ser. no. on the sheet already exists in the database? You need to describe your access database [schema](https://en.wikipedia.org/wiki/Database_schema), the table names , the field names, the field types and any constraint like primary keys. — CDP1802, Mar 01 '21 at 14:58
DataBase Name **testDB.accdb**, Table Name **MyTable** , Fields names are following (SR. NO., NAME, LOCATION, CONTACT, DESCRIPTION, QUANTITY, UNIT TYPE, RATE, TOTAL). Actually it is similar to this link. [link](https://stackoverflow.com/questions/66238939/how-to-transfer-vba-userform-data-to-access-database). — Prabhat Vishwas, Mar 02 '21 at 04:26
Sir There is a little mistake. First Field Name is "**Sr**" not "**SR. NO.**" — Prabhat Vishwas, Mar 02 '21 at 04:49

CDP1802 · Accepted Answer · 2021-03-04T08:15:12.553

I changed fieldname "NAME" to COMPANY as NAME is a reserved word

Option Explicit

Sub SaveToDB()

    Const DBNAME = "testDB.accdb"
    Const COL_SR = "C"

    Dim sCon As String, oCon As ADODB.Connection
    Dim sPath As String, SQL As String, sFields As String, t0 As Single
    t0 = Timer

    ' build SQL
    sFields = Join(Array("SR", "COMPANY", "LOCATION", "CONTACT", _
                         "DESCRIPTION", "QUANTITY", "UNIT_TYPE", _
                         "RATE", "TOTAL"), ",")

    SQL = " INSERT INTO MyTable (" & sFields & _
          ") VALUES (?,?,?,?,?,?,?,?,?)" ' 9 fields
    
    'Debug.Print SQL
   
    ' open connection to database
    sPath = ThisWorkbook.Path & "\"
    sCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sPath & DBNAME & ";"
  
    Set oCon = New ADODB.Connection
    oCon.Open sCon

    ' command with parameters
    Dim cmd As ADODB.Command
    Set cmd = New ADODB.Command
    With cmd
        .ActiveConnection = oCon
        .CommandText = SQL
        .CommandType = 1 'adCmdText
        .Parameters.Append .CreateParameter("P1", adVarChar, 1, 255) ' SR
        .Parameters.Append .CreateParameter("P2", adVarChar, 1, 255) ' COMPANY
        .Parameters.Append .CreateParameter("P3", adVarChar, 1, 255) ' LOCATION
        .Parameters.Append .CreateParameter("P4", adVarChar, 1, 255) ' CONTACT
        .Parameters.Append .CreateParameter("P5", adVarChar, 1, 255) ' DESCRIPTION
        .Parameters.Append .CreateParameter("P6", adNumeric, 1) ' QUANTITY
        .Parameters.Append .CreateParameter("P7", adVarChar, 1, 255) ' UNIT_TYPE
        .Parameters.Append .CreateParameter("P8", adNumeric, 1) ' RATE
        .Parameters.Append .CreateParameter("P9", adNumeric, 1) ' TOTAL
    End With
    
    ' scan sheet for records to insert
    Dim wb As Workbook, wsItem As Worksheet
    Dim iLastRow As Long
    
    Set wb = ThisWorkbook
    Set wsItem = wb.Sheets("ITEM DATA")
    iLastRow = wsItem.Cells(Rows.count, COL_SR).End(xlUp).Row
    'Debug.Print iLastRow

    If iLastRow = 1 Then
        MsgBox "No records to insert", vbExclamation
        Exit Sub
    End If

    ' INSERT new recordz
    Dim col(8), n, i, iRow As Long, count As Long

    For iRow = 2 To iLastRow

        For i = 0 To 8
            col(i) = wsItem.Range("C2").Offset(iRow - 2, i).Value
        Next
        col(5) = CDec(col(5)) ' decimal
        col(7) = CDec(col(7))
        col(8) = CDec(col(8))
    
        ' execute INSERT rows affected, parameters
        cmd.Execute n, col
        count = count + n
    
    Next
    MsgBox count & " rows inserted into MyTable", vbInformation, Int(Timer - t0) & " seconds"
    oCon.Close
 
    ' clear sheet
    wsItem.Range("C2:K" & iLastRow).Interior.Color = vbYellow
    wsItem.Range("C2:K" & iLastRow).Clear

End Sub

Your input sub re-written using Find and FindNext to avoid repeated scans.

Sub SaveInvoice()

    Const COL_SRNO = "C"
    Const ROW_FIRST = "7" ' first item

    Dim wb As Workbook, wsBill As Worksheet, wsItem As Worksheet
    Dim SerNo As String, rng As Range, iLastItem As Long, iLastRow As Long
    Dim d As Long, i As Long, n As Long, msg As String, t0 As Single

    Set wb = ThisWorkbook
    t0 = Timer
    
    Set wsBill = wb.Sheets("BILL FORMAT")
    Set wsItem = wb.Sheets("ITEM DATA")
    iLastRow = wsItem.Cells(Rows.count, COL_SRNO).End(xlUp).Row
    'Debug.Print iLastRow

   ' search and delete any existing serno in column C
    SerNo = wsBill.Range("B1").Value
    If Len(SerNo) = 0 Then
        MsgBox "Serial Number is blank", vbCritical
        Exit Sub
    End If
   
    With wsItem.Range(COL_SRNO & "2:" & COL_SRNO & iLastRow)
        Set rng = .Find(What:=SerNo, _
            LookIn:=xlValues, _
            LookAt:=xlWhole, _
            SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious, _
            MatchCase:=False)
        
        ' delete rows if found
        Do While Not rng Is Nothing
            'Debug.Print "Delete", rng.Address
            rng.EntireRow.Delete
            d = d + 1
            If d > iLastRow Then Exit Sub ' infinite loop protection

            Set rng = .FindPrevious
        Loop
    End With

    ' find next blank row
    iLastRow = wsItem.Cells(Rows.count, COL_SRNO).End(xlUp).Row

    ' last item
    iLastItem = wsBill.Cells(Rows.count, "A").End(xlUp).Row
     
    ' copy bill items
    n = ROW_FIRST
    For n = ROW_FIRST To iLastItem
        If Len(wsBill.Range("A" & n)) > 0 Then
            i = i + 1
            With wsItem.Cells(iLastRow + i, COL_SRNO)
                .Offset(0, 0) = Trim(wsBill.Range("B1")) ' SR NO
                .Offset(0, 1) = Trim(wsBill.Range("B2")) ' NAME
                .Offset(0, 2) = Trim(wsBill.Range("B3")) ' LOCATION
                .Offset(0, 3) = Trim(wsBill.Range("B4")) ' CONTACT
                .Offset(0, 4).Resize(1, 5) = wsBill.Range("A" & n).Resize(1, 5).Value
            End With
        End If
    Next

    ' result
    msg = d & " rows deleted " & vbCrLf & i & " rows inserted"
    MsgBox msg, vbInformation, Int(Timer - t0) & " seconds"

    ' next serial no
    With wsBill
       .Activate
       .Range("B1").Value = .Range("B1").Value + 1
       '.Range("B2:B4").ClearContents
       '.Range("A7:D11").ClearContents
       .Activate
       .Range("B2").Select
    End With

End Sub

Perfect Sir, No Doubt, You are my hero. Thank You very much. Some little changes required but now I will do it myself. Thank You very much. — Prabhat Vishwas, Mar 04 '21 at 04:27
Thank You Sir, This is working, but how to do this at one click without duplicate entry in database. Actually pop-up messages are irrelevant (I think This is not necessary). and I found QUANTY and RATE columns are same values in database. — Prabhat Vishwas, Mar 04 '21 at 05:30
@prabhat I have corrected the Quantity and Rate columns see update. — CDP1802, Mar 04 '21 at 08:36

Updating Invoice Data to Access Database with VBA

1 Answers1