将整行从一张excel表复制到另一张表的下一个空行

Posted 2023-02-24

【中文标题】将整行从一张excel表复制到另一张表的下一个空行

【英文标题】：Copying entire row from one excel sheet to next empty row of another sheet

【发布时间】：2018-02-01 04:19:02

【问题描述】：

我有两张表 data 和 PrevErrCheck。我正在检查工作表数据中所有出现的变量VarVal（此变量在PrevErrCheck 的E1 单元格中有数据）并将整行复制到工作表PrevErrCheck。但我在这里面临的问题是多次运行宏覆盖数据。我想将复制的行保留在工作表数据中，下次运行时，它应该复制到下一个空白行。

我目前正在使用下面的代码，但对如何集成在PrevErrCheck 上查找最后一行的选项并复制下面的行有点困惑

Sub PrevErrCheck()    
    Dim spem As Workbook
    Dim PrevErrCheck As Worksheet
    Dim data As Worksheet
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long

    Set spem = Excel.Workbooks("SwitchPortErrorMonitor.xlsm")
    Set PrevErrCheck = spem.Worksheets("PrevErrCheck")
    Set data = spem.Worksheets("data")

    spem.Worksheets("PrevErrCheck").Activate 
    VarVal = PrevErrCheck.Cells(1, "E").Value
    I = data.UsedRange.Rows.count
    J = PrevErrCheck.UsedRange.Rows.count

    If J = 1 Then
        If Application.WorksheetFunction.CountA(PrevErrCheck.UsedRange) = 0 Then J = 0
    End If

    Set xRg = data.Range("X:X")
    On Error Resume Next

    Application.ScreenUpdating = False

    J = 3
    For K = 1 To xRg.count      
        If CStr(xRg(K).Value) = VarVal And Not IsEmpty(VarVal) Then
            xRg(K).EntireRow.Copy Destination:=PrevErrCheck.Range("A" & J + 1)
            PrevErrCheck.Range("X" & J + 1).ClearContents
            J = J + 1
        End If    
    Next

    Application.ScreenUpdating = True
End Sub

【问题讨论】：

所以你得到一个错误？哪个错误，在哪一行？请在您的问题中包含这一点。

J = J + 1 也许

首先删除On Error Resume Next。此语句使您在调试过程中失明，它使所有错误消息静音，但错误仍然存​​在。如果没有适当的错误处理，则应该永远不要使用它！

【参考方案1】：

你在循环之前有J = 3，这可能是个问题。 xRg.count 总是返回 1048576，你应该使用更具体的东西。试试这个：

Set spem = Excel.Workbooks("SwitchPortErrorMonitor.xlsm")
Set PrevErrCheck = spem.Worksheets("PrevErrCheck")
VarVal = PrevErrCheck.Cells(1, "E").Value
If IsEmpty(VarVal) Then Exit Sub

Set data = spem.Worksheets("data")

spem.Worksheets("PrevErrCheck").Activate
I = data.UsedRange.Rows.Count
J = PrevErrCheck.UsedRange.Rows.Count + 1
If J = 2 Then
    If IsEmpty(PrevErrCheck.Cells(1, 1)) Then J = 1
End If

'    If J = 1 Then
'        If Application.WorksheetFunction.CountA(PrevErrCheck.UsedRange) = 0 Then J = 0
'    End If

'    Set xRg = data.Range("X:X")
'    On Error Resume Next

'    Application.ScreenUpdating = False

'    J = 3
For K = 1 To I
    If CStr(data.Cells(K, "X").Value) = VarVal Then
        data.Cells(K, 1).EntireRow.Copy Destination:=PrevErrCheck.Range("A" & J)
        PrevErrCheck.Range("X" & J).ClearContents
        J = J + 1
    End If
Next

'   Application.ScreenUpdating = True
End Sub