用空白单元格覆盖

Question

我遇到宏问题。 VBA代码如下。最初设计的目的是让用户每天输入所有数据并运行一次宏以复制到另一张工作表。现在用户正在输入一些数据，运行宏并稍后返回以输入更多数据。每次运行宏时，当天的先前数据都会被空白单元格和少量新数据覆盖。

Sub copyHME()

    Dim inputSheet As Worksheet
    Set inputSheet = ActiveWorkbook.Worksheets("Data Entry - HME")
    
    Dim copyRange As Range
    Set copyRange = inputSheet.Range("H4:H200")
    
    Dim outputSheet As Worksheet
    Set outputSheet = ActiveWorkbook.Worksheets("SMU - HME")
        
    Dim searchRange As Range
    Set searchRange = outputSheet.Range("3:3")
       
    Dim dateCell As Range
    Set dateCell = inputSheet.Range("H2")
    
    Dim targetDate As Variant
    targetDate = DateTime.DateValue(dateCell.Value)
    
    'Unprotect the sheet "SMU - HME"
    Sheets("SMU - HME").Unprotect Password:="XXX"
    
    'Clears all filters - if filters are left before next action data gets copied into the incorrect cells
    If ActiveSheet.AutoFilterMode Then
        ActiveSheet.AutoFilter.ShowAllData
    End If
    
    Dim currentCell As Range
    For Each currentCell In searchRange
        If IsDate(currentCell.Value) Then
            If DateTime.DateValue(currentCell.Value) = targetDate Then
                Exit For
            End If
        End If
    Next
    
    If Not currentCell Is Nothing Then
        inputSheet.Activate
        copyRange.Select
        Selection.Copy
        outputSheet.Activate
        currentCell.Offset(1, 0).Select
        Call Selection.PasteSpecial(xlPasteValues)
        Application.CutCopyMode = False
    End If

    Call MacroLock
         
    Sheets("Data Entry - HME").Select
    MsgBox "Data entry completed"
    
End Sub

我一定缺少一些简单的东西。

Answer 1

• 修改后的代码仅将增量数据复制到目标表。

例如，

• 如果用户在H4:H10输入数据，则运行复制数据代码
• 然后在H11:H20中输入数据，再次运行代码只会复制H11:H20，无论H4:H10是否有变化。
• 如果用户想再次复制所有数据，必须清除目标表中的数据。

    If Not currentCell Is Nothing Then
        Set currentCell = outputSheet.Cells(outputSheet.Rows.Count, currentCell.Column).End(xlUp)
        If currentCell.Row < 201 Then
            With inputSheet.Range("H" & currentCell.Row + 1 & ":H200")
                currentCell.Resize(.Cells.Count, 1).Value = .Value
            End With
        End If
    End If