l formularz do zapisywania danych w programie Access - Excel

Dzień dobry wszystkim !!

Zarządzam centrum kontaktowym i wymagam od pracowników przechwytywania niektórych danych w celu obliczenia ich wydajności

Można to łatwo zrobić poprzez formularze ACCESS, ale zespół nie może mieć dostępu z powodu niektórych zasad

Chciałem wiedzieć, czy mam utworzyć kilka predefiniowanych pól w programie Excel do wprowadzania danych (listy rozwijane i trochę tekstu), gdzie agenci wprowadzają informacje za każdym razem, a następnie kliknij przycisk "Prześlij".

Po kliknięciu przycisku "Prześlij" dane są następnie przekazywane do tabeli ACCESS, a pola Excela są zerowane.

Uwaga: Każdy agent ma plik excela z nazwą zapisaną na naszym wspólnym dysku. ACCESS jest również przechowywany na wspólnym dysku. Ścieżki są wstępnie zdefiniowane i naprawione.

Czy ktoś może ci w tym pomóc?

Jestem pewien, że zostało to wcześniej opublikowane, ale nie mogę znaleźć dokładnych wymagań.

Dzięki

Odpowiedzi:

To powinno działać. Skopiuj, wklej i dostosuj nazwę skoroszytu.

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

Edytować:

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