I wrote this macro to populate an access database with the contents from a protected spreadsheet that was distributed to users in different countries. The Excel file was used for Sales Order Entry. I have removed sections for security purposes, however this should serve as a good starting point for you to start your own version.
The idea is to ensure that the data integrity before loading the file and then marking the excel file as imported to prevent accidental duplication in the upload.
I have added comments to the code to explain the main sections, If you have any questions leave a comment.
'generic format
Sub XML_LoadXLTemplate()
' ExportData Macro
' Version 1.0 2-Apr-09
' Designed to export data to the xml data store
'-------------------------------------------------
Dim tmpTest As Boolean, myfile, tmpStr, tmpFile, tmpPath, x, tmpCells, tmpCount, tmpShipName, tmpAPO
Dim rst As Recordset, db As Database, tmpCountry, tmpEntity, tmpODate, tmpOrderRef, tmpShip5, tmpShip6
Dim tmpShip1, tmpShip2, tmpShip3, tmpShip4, tmpArea, tmpWH, tmpPriceList, tmpStartSheet, tmpShipDate
Dim tmpFailures, rstStock As Recordset, tmpRequestor
Dim tmpPhone, tmpEmail, tmpAttention, tmpWarranty, tmpCrystal, tmpShipVia, tmpShipViaAccount
'|------------------------------------
'|need to set a reference to DAO , under tools
'|references Microsoft DAO 3.6...
'|--------------------------------------
Set db = OpenDatabase("\serverYouDatabase.mdb")
Set rst = db.OpenRecordset("tblImportData")
tmpTest = True
tmpStr = ""
Application.ScreenUpdating = False
tmpStartSheet = ActiveSheet.Name
Range("I1").Select
' This cell is populated after the data is imported to ensure the user does not accidentally duplicate the load
If ActiveCell.Value = "Data Imported" Then
If MsgBox("This sheet has already been imported, Import Again ?", vbYesNo + vbDefaultButton2) = vbNo Then
Exit Sub
End If
End If
Range("A1").Select
If FoundWS("SheetName") = False Then ' FOR FUNCTION SEE http://www.ozgrid.com/forum/showthread.php?t=38108
MsgBox "Cannot find the Order Sheet SheetName"
Exit Sub
End If
Sheets("SheetName").Select
'now check the control cells
tmpFailures = ""
Range("D6").Select
If Len(ActiveCell.Value & "") = 0 Then
tmpFailures = tmpFailures & "This Order must Contain the Entity Code at D6" & vbCrLf
End If
Range("D7").Select
If Len(ActiveCell.Value & "") = 0 Then
tmpFailures = tmpFailures & "No Entity name entered at D7 " & vbCrLf
End If
' you can add as many checks to the integrity of the sheet before starting the load
'now check the order lines
Range("a28").Select
i = 1
Do While i < 86 ' I had max 86 lines to validate
If ActiveCell.Offset(0, 7).Value > 0 Then
If Len(ActiveCell.Offset(0, 1).Value & "") = 0 Then
tmpFailures = tmpFailures & "Order Line #" & i & " No part number entered" & vbCrLf
End If
End If
i = i + 1
ActiveCell.Offset(1, 0).Select
Loop
If Len(tmpFailures & "") > 0 Then
MsgBox "Order Validation Failed " & vbCrLf & vbCrLf & tmpFailures
Exit Sub
End If
'now move to the first line defined by A2
Range("d6").Select
'set the variables
tmpEntity = ActiveCell.Value
tmpCountry = ActiveCell.Offset(1, 0).Value
tmpShipName = ActiveCell.Offset(3, 0).Value
tmpShip1 = ActiveCell.Offset(4, 0).Value
tmpShip2 = ActiveCell.Offset(5, 0).Value
tmpShip3 = ActiveCell.Offset(6, 0).Value
tmpShip4 = ActiveCell.Offset(7, 0).Value
tmpShip5 = ActiveCell.Offset(8, 0).Value
tmpShip6 = ActiveCell.Offset(9, 0).Value
tmpAttention = ActiveCell.Offset(10, 0).Value
tmpPhone = ActiveCell.Offset(11, 0).Value
tmpEmail = ActiveCell.Offset(12, 0).Value
Range("A28").Select
tmpCells = 28
'move to the start
Cells(tmpCells, 1).Select
'check the value in a1 & h1 is numeric
Do While tmpCount < 86
If ActiveCell.Offset(0, 7).Value > 0 Then
'Add the contents to the database
With rst
.AddNew
!O_Entity = tmpEntity
!O_Date = tmpODate
!O_Part = ActiveCell.Offset(0, 1).Value
!O_PartOrg = ActiveCell.Offset(0, 1).Value
'!O_AltPart = ActiveCell.Offset(0, 2).Value
!O_Desc = Left(ActiveCell.Offset(0, 3).Value, 200)
!O_qty = ActiveCell.Offset(0, 7).Value
!O_price = ActiveCell.Offset(0, 9).Value
!O_Price2 = 0 'ActiveCell.Offset(0, 9).Value
!O_Extended = !O_qty * !O_price 'ActiveCell.Offset(0, 7).Value
!O_ImpDate = Now()
!O_LineShipDate = IIf(Len(ActiveCell.Offset(0, 7).Value & "") = 0, tmpShipDate, ActiveCell.Offset(0, 7).Value)
!O_OrderDate = tmpODate
!O_Ship1 = tmpShip1
!O_Ship2 = tmpShip2
!O_Ship3 = tmpShip3
!O_Ship4 = tmpShip4
!O_Ship5 = tmpShip5
!O_Ship6 = Left(tmpShip6, 9)
!O_ShipName = tmpShipName
!O_Phone = tmpPhone
!O_EmailAddress = tmpEmail
!O_Crystalid = tmpCrystal
!O_Warranty = tmpWarranty
!O_ShipVia = tmpShipVia & " " & tmpShipViaAccount
!O_Requestor = tmpRequestor
!O_Attention = tmpAttention
!O_Text = 1
!O_Warehouse = ""
!O_Number = tmpOrderRef & "-" & !O_Warehouse
Set rstStock = Nothing
!O_PriceList = "A"
.Update
End With
End If
ActiveCell.Offset(1, 0).Select
tmpCount = tmpCount + 1
Loop
MsgBox "Database updated"
End Sub