Copy/Paste 基于条件的数据日志

Question

当您反复单击“开始”按钮时，以下代码将一行数据从仪表板复制到 Data_Log。我正在尝试添加一个条件，即每次 Yes 出现在时间日志的 D 列中时，将数据从仪表板复制到 Data_Log 并且只单击“开始”按钮一次以启动它应该持续运行，直到您按下“停止”按钮。

问题是 Time_Log 上出现 Yes 条件时我无法复制数据。

逻辑 -> Yes 的条件出现在 Time_Log -> 从仪表板复制 -> 粘贴到 Data_Log -> 继续到 copy/paste 作为 [=随着时间的推移，12=] 在 Time_Log 上递增。谢谢你的帮助。

Option Explicit

Dim LoggingActive As Boolean
Public Sub StartLoggingData()
    Application.StatusBar = "Logging Dashboard Started"
    LoggingActive = True
    CopyData
End Sub
Public Sub StopLoggingData()
    Application.StatusBar = "Logging Dashboard Stopped"
    LoggingActive = False
End Sub
 
Private Sub CopyData()
 
    Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet, cpyRng As Range, logRng As Long, rngLogTargetBeginningCell As Range, rngLastCellSelection As Range, r As Long, lastRow As Range
 
    If LoggingActive = True Then

        Set sht1 = ThisWorkbook.Sheets("Dashboard")
        Set sht2 = ThisWorkbook.Sheets("Data_Log")
        Set sht3 = ThisWorkbook.Sheets("Time_Log")
        Set cpyRng = sht1.Range("A39:Q39")
        Set rngLogTargetBeginningCell = sht2.Rows(sht2.Rows.Count).Columns(1).End(xlUp).Offset(1, 0)
        Set rngLastCellSelection = Selection ' remember the last selection because pasting will change the active cell
 
        Application.ScreenUpdating = False ' Stop Updating Graphic during data copy
        lastRow = sht3.Cells(Rows.Count).End(xlUp).Row
        For r = 4 To lastRow
            If sht3.Range("D" & r).Value = "Yes" Then
                cpyRng.Copy
                rngLogTargetBeginningCell.Offset(0, 1).PasteSpecial xlPasteValues
                rngLastCellSelection.Select    ' reselect the old cell
            End If
        Next r
    End If
    Application.CutCopyMode = False ' Remove the copy area marker
    Application.ScreenUpdating = True  ' update graphics again
End Sub

Answer 1

lastRow 被键入为 Range 而不是数字数据类型。 wsTime_Log.Cells(Rows.Count) 指的是空列 1。

lastRow As Range
lastRow = wsTime_Log.Cells(Rows.Count).End(xlUp).Row

rngLogTargetBeginningCell应该在循环内部确定。

更正

lastRow As Long
lastRow = wsTime_Log.Cells(Rows.Count, "D").End(xlUp).Row

重构代码

Dim LoggingActive As Boolean

Public Sub StartLoggingData()
    Application.StatusBar = "Logging Dashboard Started"
    LoggingActive = True
    CopyData
End Sub

Public Sub StopLoggingData()
    Application.StatusBar = "Logging Dashboard Stopped"
    LoggingActive = False
End Sub
 
Private Sub CopyData()
    LoggingActive = True
    
    Dim r As Long, lastRow As Long
    Dim ValidationRange As Range
    Set ValidationRange = TimeLogValidationRange
    
    If LoggingActive = True Then

        Application.ScreenUpdating = False ' Stop Updating Graphic during data copy
    
        For r = 1 To ValidationRange.Rows.Count
            If ValidationRange.Cells(r, 1).Value = "Yes" Then
                With DashboardDataRange
                    NewData_LogRow.Resize(.Rows.Count, .Columns.Count).Value = .Value
                End With
            End If
        Next r
    End If
    
    Application.ScreenUpdating = True  ' update graphics again
End Sub

Function TimeLogValidationRange() As Range
    With wsTime_Log
        Set TimeLogValidationRange = .Range("A1", .UsedRange).Columns("D")
        With TimeLogValidationRange
            Set TimeLogValidationRange = TimeLogValidationRange.Offset(3).Resize(.Rows.Count - 3)
        End With
    End With
End Function

Function DashboardDataRange() As Range
    Set DashboardDataRange = wsDashboard.Range("A39:Q39")
End Function

Function NewData_LogRow() As Range
    With wsData_Log
        Set NewData_LogRow = .UsedRange.Columns(1)
        Set NewData_LogRow = NewData_LogRow.Offset(NewData_LogRow.Rows.Count).Resize(1).EntireRow
    End With
End Function

Function wsDashboard() As Worksheet
    Set wsDashboard = ThisWorkbook.Sheets("Dashboard")
End Function

Function wsData_Log() As Worksheet
    Set wsData_Log = ThisWorkbook.Sheets("Data_Log")
End Function

Function wsTime_Log() As Worksheet
    Set wsTime_Log = ThisWorkbook.Sheets("Time_Log")
End Function

我喜欢为我的所有范围创建辅助函数。这使我可以像这样准确地测试所引用的内容：

Application.Goto TimeLogValidationRange
Application.Goto DashboardDataRange
Application.Goto NewData_LogRow

Copy/Paste 基于条件的数据日志

Copy/Paste Data Log Based on a Condition

arrays

excel

vba

copy-paste

worksheet-function

更正

重构代码