Question

大家好日子!!

我管理一个联络中心，并要求员工捕获一些数据来计算他们的生产力

这可以通过ACCESS表单轻松完成，但由于某些政策，团队不允许拥有ACCESS

我想知道我是否要在Excel中为数据输入创建一些预定义字段（下拉列表和一些自由文本），代理每次都输入信息，然后单击＆＃34;提交＆＃34;按钮。

一旦＆＃34;提交＆＃34;单击按钮，然后将数据传递到ACCESS表，并将excel字段重置为空白。

注意：每个代理都有一个excel文件，其名称存储在我们的共享驱动器上。 ACCESS也存储在共享驱动器上。路径是预定义和修复的。

任何人都可以帮助解决这个问题

我确定之前发布过这个帖子，但我似乎无法找到确切的要求。

由于

Answer 1

那应该有用。复制，粘贴和调整工作簿名称。

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

编辑：

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

l表单在Access中保存数据

1 个答案: