VBA复制/粘贴

Question

我在Excel工作簿中有80台计算机和80个选项卡。在每个选项卡上的（A）列中都有一个月日期的列表，在（C）列中有一个条目，表示该机器在该月中工作了多少小时。因此，每天的增长在0（如果机器故障）和24之间。

我正在寻找一种解决方案，以在每天添加零小时的情况下自动执行记录。在这种情况下，必须将前一天的累计总数复制到（C）列的第二天的单元格中。

我确信它非常简单，但无法解决，而且我之前在网上也没有找到类似的问题。

提前感谢

伊恩

Answer 1

下面的代码将允许您输入每天的总小时数。它将把您输入的数字添加到上一个总数中，然后用总和替换您的输入。您可以输入零，从而得到一个新的总数，与之前的总数相同。输入后，代码将跳至下一页，选择当天要填充的单元格并突出显示绿色。如果已经有一个条目，则突出显示将为粉红色。

如果前几天没有条目，则将假定没有工作时间，并且相应记录在您输入当前小时数所在行的上方完成。您不能输入负数的小时数或超过24的小时数。您不能在要修改的单元格下面有条目的单元格中输入，即使该单元格为空白。

该代码由两个部分组成。第一部分需要进入标准代码模块。这是您的工作簿中不存在的一个。找到添加模块的方法。如果其名称类似于Module1，则其正确。将下面的代码粘贴到其中。我希望重命名模块（例如“ STO_200408”），但这不是必需的。

Option Explicit

Enum Nws                                ' worksheet navigation
    ' Variatus @STO 08 Apr 2020
    NwsFirstDataRow = 2                 ' modify if your data don't start in row 2
    NwsDate = 1                         ' date column: 1 identifies column A
    NwsHours = 3
End Enum

Sub WorksheetActivate(Ws As Worksheet)
    ' Variatus @STO 08 Apr 2020

    Dim Rng As Range

    Set Rng = Ws.Columns(NwsDate).Find(Date, , , xlWhole)
    If Rng Is Nothing Then
        MsgBox "I didn't find today's date on the """ & _
               Ws.Name & """." & vbCr & _
               "It may have been entered using an invalid format.", _
               vbInformation, "Missing or invalid date"
    Else
        WorksheetDeactivate Ws              ' remove existing highlight
        With Rng.Resize(1, NwsHours)
            .Interior.Color = IIf(.Cells(NwsHours).Value, 13431551, 14348258)
            .Cells(NwsHours).Select
        End With
    End If
End Sub

Function WorksheetChange(Target As Range) As Boolean
    ' Variatus @STO 08 Apr 2020
    ' return Not True if accumulator couldn't be set

    Dim Rng As Range
    Dim Hours As Double
    Dim Accu As Double
    Dim R As Long

    With Target
        If .Cells.CountLarge > 1 Then Exit Function

        With .Worksheet
            R = .Cells(.Rows.Count, NwsDate).End(xlUp).Row
            Set Rng = .Range(.Cells(NwsFirstDataRow, NwsHours), _
                             .Cells(R, NwsHours))
        End With

        If Not Application.Intersect(Target, Rng) Is Nothing Then
            Application.EnableEvents = False
            If GetAccu(Accu, Target.Worksheet, .Row) Then
                Hours = Val(.Value)
                ' modify if you record time hours:-
                If (Hours > 24) Or (Hours < 0) Then
                    MsgBox "Please enter a positive value smaller or equal to 24 hours.", _
                           vbExclamation, "Invalid number of hours"
                    GoTo SideExit
                End If
                .Value = Accu + Val(.Value)
                WorksheetChange = True
            Else
SideExit:
                .Select
            End If
            Application.EnableEvents = True
        End If
    End With
End Function

Sub WorksheetDeactivate(Ws As Worksheet)
    ' Variatus @STO 08 Apr 2020

    Dim Rng As Range

    With Ws
        Set Rng = .Range(.Cells(NwsFirstDataRow, NwsDate), _
                         .Cells(.Rows.Count, NwsDate).End(xlUp) _
                                .Offset(0, NwsHours - 1))
        Rng.Interior.Pattern = xlNone
    End With
End Sub

Private Function GetAccu(Accu As Double, _
                         Ws As Worksheet, _
                         ByVal Rt As Long) As Boolean
    ' Variatus @STO 08 Apr 2020
    ' 'Accu' is a return variable
    ' return Not True if no b/f total could be determined

    Dim R As Long

    With Ws
        If .Cells(.Rows.Count, NwsHours).End(xlUp).Row > Rt Then
            MsgBox "There may be no entries in the 'Hours' column" & vbCr & _
                   "below the entry now being processed." & vbCr & _
                   "Remove existing entries and repeat.", _
                   vbExclamation, "Record irregularity"
        Else
            GetAccu = True
            With .Cells(NwsFirstDataRow, NwsHours)
                If Len(.Value) = 0 Then .Value = 0
            End With

            R = Rt
            Do
                R = R - 1
                With .Cells(R, NwsHours)
                    If Len(.Value) Then
                        Accu = Val(.Value)
                        Exit Do
                    End If
                End With
            Loop While R > NwsFirstDataRow

            For R = (R + 1) To (Rt - 1)
                .Cells(R, NwsHours).Value = Accu
            Next R
        End If
    End With
End Function

Sub GotoNextSheet()
    ' Variatus @STO 08 Apr 2020

    Dim Idx As Integer

    Idx = ActiveSheet.Index + 1
    If Idx > Worksheets.Count Then Idx = 1
    Worksheets(Idx).Activate
End Sub

[下一步，找到属于您要保存机器时间的工作表的代码模块。如果在VB编辑器的项目资源管理器中双击工作表的名称，则将打开正确的代码表。将您在下面找到的代码粘贴到该工作表中。

Option Explicit

Private Sub Worksheet_Activate()
    ' Variatus @STO 08 Apr 2020
    WorksheetActivate ActiveSheet
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    ' Variatus @STO 08 Apr 2020
    If WorksheetChange(Target) Then GotoNextSheet
End Sub

Private Sub Worksheet_Deactivate()
    ' Variatus @STO 08 Apr 2020
    WorksheetDeactivate ActiveSheet
End Sub

此代码将工作表上发生的事情与Module1中的代码联系起来。现在，您可以在该工作表的C列中输入条目，然后查看操作。我建议您这样做以同时测试代码及其位置。

由于您希望对所有80张纸进行操作，因此应将相同的代码粘贴到全部80张纸的代码表中。请注意，如果使用右键单击选项卡来创建代码，则该代码将被复制到工作表副本中。如果您选择整个工作表并将其粘贴到新工作表，则不会。因此，要开始一个新的月，您可以从包含代码的模板创建副本，而不必担心单独复制代码。

一旦您所有的80张纸都带有您要设置的事件代码。请注意，该代码将在每次输入后跳到下一个工作表，并在到达最后一个时循环回到第一个工作表。当您看到高光的颜色变为粉红色并且所选单元格已包含总和时，您将知道完成此操作。