Question

如果我的目的地中已经有数据，则当我对其进行测试时，我的复制和粘贴代码可以正常工作。我需要它从头开始工作而没有数据，以便部门开始输入自己的数据。我注意到，如果我没有数据，它将粘贴在我的数据范围的顶部，或替换已经存在的数据。我需要它来开始在单元格E7中进行第一个粘贴，然后针对每组新数据偏移到下一行。

目标变量似乎已崩溃（完整代码如下：

'目标变量

lstrow = Sheet3.Range("E" & Rows.Count).End(xlUp)
If lstrow < 5 Then lstrow = 5
Set DstRng = Sheet3.Range("E" & lstrow).Offset(1, 0)
Set DstRng = DstRng.Resize(SrcRng.Rows.Count, SrcRng.Columns.Count)

整个代码

Sub CopyCells()
'unprotect all sheets
'Unprotect_All
'dim variables
Dim DstRng As Range 'destination range
Dim SrcRng As Range 'source range
Dim Proceed As Boolean ' do we wish to proceed
Dim checkRng As Variant ' values to check
Dim i As Integer
Dim lstrow As Long

'These are mandatory fields and the error message
checkRng = Array( _
            Array("E3", "Please add the Agent Name"), _
            Array("H3", "The Evaluation Date is missing"), _
            Array("J3", "The Call Date is missing"), _
            Array("M3", "The Call ID is missing"), _
            Array("Q58", "Please score this evaluation before saving") _
            )
'Set proceed to true so this is the case unless it changes
Proceed = True

'source variable
Set SrcRng = Sheet1.Range("Eval_Data")

'destination variable
lstrow = Sheet3.Range("E" & Rows.Count).End(xlUp)
If lstrow < 5 Then lstrow = 5
Set DstRng = Sheet3.Range("E" & lstrow).Offset(1, 0)
Set DstRng = DstRng.Resize(SrcRng.Rows.Count, SrcRng.Columns.Count)

'mandatory fields
For i = 0 To 4
    If Len(Sheet1.Range(checkRng(i)(0))) = 0 Then
        Proceed = False
        MsgBox checkRng(i)(1)
        Sheet1.Range(checkRng(i)(0)).Activate
        Exit For
    End If
Next i

' if proceed is all good then go ahead
If Proceed = True Then
'give the user a chance to exit here
    If MsgBox _
        ("You are about to finalize this Evaluation." _
        & vbCrLf & "Please check everything before you proceed", _
        vbYesNo Or vbExclamation, "Are you sure?") = vbYes Then

        'copy and paste data without selecting
        DstRng.Value = SrcRng.Value

        'add Eval number
        With Sheet1.Range("H4")
            .Value = .Value + 1
        End With

        'confirmation message
        MsgBox "The Evaluation has been saved"

        'clear the invoice
        ClearEval
    End If
End If
'reprotect
'Protect_All
End Sub

Answer 1

 lstrow = Sheet3.Range("E" & Rows.Count).End(xlUp)

'从底部开始，一直向上直到遇到占据的单元格或电子表格的顶部

 If lstrow < 5 Then lstrow = 5

'如果您的行数少于5，则将指针设置为5

Set DstRng = Sheet3.Range("E" & lstrow).Offset(1, 0)

'在一张空白纸上，我们现在在E6

Set DstRng = DstRng.Resize(SrcRng.Rows.Count, SrcRng.Columns.Count)

'这不会使dstrng从E6移到顶部

“我需要它来开始在E7单元格中开始粘贴”
你能发现问题吗？

Answer 2

这可能是完成您所需的有效方法：

With sheet3
    lstrow = Application.WorksheetFunction.Max(7, .Range("E" & .Rows.Count).End(xlUp).Offset(1).Row)
    Set DstRng = .Range("E" & lstrow).Resize(SrcRng.Rows.Count, SrcRng.Columns.Count)
End With

VBA目标变量复制问题

2 个答案: