将非空白单元格从 sheet1 复制并粘贴到 sheet2答案

【问题标题】：Copy and paste nonblank cells from sheet1 to sheet2将非空白单元格从 sheet1 复制并粘贴到 sheet2
【发布时间】：2022-07-15 05:17:34
【问题描述】：

我正在尝试将非空白单元格从 sheet1 复制并粘贴到 sheet2。

我收到应用程序/对象错误。

Public Sub CopyRows()
    Sheets("Sheet1").Select
    FinalRow = Cells(Rows.Count, 1).End(xlDown).Row
    For x = 4 To FinalRow
        ThisValue = Cells(x, 1).Value
        NextRow = Cells(Rows.Count, 1).End(xlDown).Row
        If Not IsEmpty(ThisValue) Then
            Cells(x, 1).Resize(1, 6).Copy
            Sheets(2).Select
            Cells(NextRow, 1).Select
            ActiveSheet.Paste
            Sheets(1).Select
        End If
    Next x
End Sub

【问题讨论】：

一般来说，你想在你的代码中avoid using Select。最好指定给定范围在哪个工作表中（例如：Sheets(1).Cells(x, 1).Value 而不是 Cells(x, 1).Value）

标签： excel vba

【解决方案1】：

复制行

Option Explicit

Sub CopyRows()
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
    If slRow < 4 Then Exit Sub ' no data
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet2")
    Dim dCell As Range: Set dCell = dws.Cells(dws.Rows.Count, "A").End(xlUp)
    
    Application.ScreenUpdating = False
    
    Dim sCell As Range
    Dim sr As Long
    
    ' Loop and copy.
    For sr = 4 To slRow
        Set sCell = sws.Cells(sr, "A")
        If Not IsEmpty(sCell) Then
            Set dCell = dCell.Offset(1)
            sCell.Resize(, 6).Copy dCell
        End If
    Next sr
    
    Application.ScreenUpdating = True
    
    ' Inform.
    MsgBox "Rows copied.", vbInformation
    
End Sub

【讨论】：

【解决方案2】：

您的原始代码存在多个问题。正如cybernetic.nomad 已经指出的那样，尽可能避免使用Select。您还将NextRow 变量设置为始终是工作表中的最后一行，而不是目标工作表中的下一个可用行。此外，由于您使用了 .Select，因此您的 Cells 调用不明确。

这是使用 AutoFilter 的替代方法，因为对于此任务，您可以利用过滤来仅获取填充的单元格，而无需执行循环：

Sub CopyRows()
    
    Dim wb As Workbook:     Set wb = ActiveWorkbook
    Dim wsSrc As Worksheet: Set wsSrc = wb.Worksheets("Sheet1")
    Dim wsDst As Worksheet: Set wsDst = wb.Worksheets("Sheet2")
    Dim rData As Range:     Set rData = wsSrc.Range("A3", wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp))
    If rData.Rows.Count < 2 Then Exit Sub  'No data
    
    With rData
        .AutoFilter 1, "<>"
        .Offset(1).Resize(, 6).Copy wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Offset(1)
        .AutoFilter
    End With
    
End Sub

【讨论】：