l form to save data in Access - excel

Question

Good day to all !!
I manage a contact center and require the staff to capture some data to calculate their productivity
This could've been done easily through ACCESS forms, but the team is not allowed to have ACCESS due to some policies
I wanted to know if i am to create a few predefined fields in excel for data entry (Dropdowns and some free text), where the agents enter the information each time, then click a "Submit" button.
Once the "Submit" button is clicked, the data is then passed into an ACCESS table, and the excel fields are reset to blank.
Note: Each agent has an excel file with their name stored on our shared drive. The ACCESS is also stored on the shared drive. Paths are predefined and fixed.
Can anyone please help with this
I'm sure this has been posted somewhere before, but I cant seem to find the exact requirements.
Thanks

Answer 1

That should work. Copy, paste and adjust workbook name.
Option Explicit
Sub UpdateLogWorksheet()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim wb1 As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myRng As Range
Dim myCopy As String
Dim myCell As Range
'cells to copy from Input sheet - some contain formulas
myCopy = "D5,D7,D9,D11,D13"
Set inputWks = Worksheets("Input")
Set historyWks = Worksheets("PartsData")
Set wb1 = Workbooks("1.xls").Worksheets("PartsData") 'change Workbook
With inputWks
Set myRng = .Range(myCopy)
If Application.CountA(myRng) <> myRng.Cells.Count Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With wb1
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
For Each myCell In myRng.Cells
.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
'clear input cells that contain constants
With inputWks
On Error Resume Next
With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With
End Sub
Edit:
Option Explicit
Sub UpdateLogWorksheet()
Application.ScreenUpdating = False
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim wb1 As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim wb_path As String
Dim myCopy As String
Dim wb_name As String
Dim myRng As Range
Dim myCell As Range
'cells to copy from Input sheet - some contain formulas
myCopy = "D5,D7,D9,D11,D13"
wb_name = "1.xls" '2nd workbook name
wb_path = "C:\Reports\" & wb_name '2nd workbook path on HDD
Set inputWks = ThisWorkbook.Worksheets("Input") 'form sheet
Set historyWks = ThisWorkbook.Worksheets("PartsData") 'data in form sheet
Set myRng = inputWks.Range(myCopy)
If Application.CountA(myRng) <> myRng.Cells.Count Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
'if 2nd workbook file does not exists, message will pop up
If Dir(wb_path) = "" Then
MsgBox ("File does not exists")
Exit Sub:
'if exists it will open and become invisible
Else
Workbooks.Open Filename:=wb_path
Application.Windows(wb_name).Visible = False
Set wb1 = Workbooks(wb_name).Worksheets("PartsData") 'data in 2nd workbook
'copy data to 2nd workbook
With wb1
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
For Each myCell In myRng.Cells
.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
Application.Windows(wb_name).Visible = True
Workbooks(wb_name).Close True
End If
'copy data to form sheet
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
For Each myCell In myRng.Cells
.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
'clear input cells that contain constants
With inputWks
On Error Resume Next
With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With
Application.ScreenUpdating = True
End Sub