在范围内搜索非空单元格，粘贴到新工作表答案

【问题标题】：Search for not empty cells in range, paste to new sheet在范围内搜索非空单元格，粘贴到新工作表
【发布时间】：2021-12-25 06:20:02
【问题描述】：

在 Excel 中，我正在寻找一个 VBA 宏来执行以下操作：

在“Sheet2”范围 A2:Q3500 中搜索包含数据（非空）的任何单元格，然后仅复制这些单元格。
将这些单元格的确切值粘贴到“Sheet3”中，从单元格 A2 开始。

当我说“精确值”时，我只是指单元格中的文本/数字与复制时显示的完全相同，没有应用不同的格式。

非常感谢任何指导，谢谢！

【问题讨论】：

您希望结果单元格在一行还是一列？如果例如需要做什么？在第一行，B2 和 F2:K2 是空的？ A2、C2:E2 和 L2:Q2 应该复制到哪里？或者您是否有要检查“空”（空白）的列以识别不需要的行？请务必澄清。
最简单最快的方法是复制整个范围A2:Q3500，然后在复制后对范围进行排序....
欢迎来到 SO。您应该注意 SO 不是免费的编码服务。它的目的是让编码人员帮助其他编码人员（即使提问者是一个完全的新手）。这意味着你需要尝试一下，展示你的作品，并解释为什么它不起作用。
Sheet2 将始终在所有列 A:Q 中包含数据（如果 A 列中有任何内容）。我遇到的问题是我的基本代码复制/粘贴了整个范围，而不仅仅是包含数据的行导入 Access 时，由于某些原因，空白单元格读取为非空白。我想我只需要最后一行代码的版本吗？另外我如何确保它以相同的格式粘贴？尽量避免在粘贴后触摸它。谢谢！

标签： excel vba copy-paste

【解决方案1】：

复制过滤后的数据

以下将复制完整的表格范围，然后删除“空”行。
调整常量部分中的值。

Option Explicit

Sub CopyFilterData()

    ' Source
    Const sName As String = "Sheet2"
    Const sFirst As String = "A1"
    ' Destination
    Const dName As String = "Sheet3"
    Const dFirst As String = "A1"
    Const dfField As Long = 1
    Const dfCriteria As String = "="
    ' Both
    Const Cols As String = "A:Q"
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    If sws.AutoFilterMode Then sws.AutoFilterMode = False
    Dim sfCell As Range: Set sfCell = sws.Range(sFirst)
    
    Dim slCell As Range
    With sfCell.Resize(sws.Rows.Count - sfCell.Row + 1)
        Set slCell = .Find("*", , xlFormulas, , , xlPrevious)
    End With
    If slCell Is Nothing Then Exit Sub ' no data in column range
    
    Dim rCount As Long: rCount = slCell.Row - sfCell.Row + 1
    If rCount = 1 Then Exit Sub ' only headers
    
    Dim scrg As Range: Set scrg = sfCell.Resize(rCount) ' Criteria Column Range
    Dim srg As Range: Set srg = scrg.EntireRow.Columns(Cols) ' Table Range
    Dim cCount As Long: cCount = srg.Columns.Count
    
    Application.ScreenUpdating = False
    
    ' Destination
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    If dws.AutoFilterMode Then dws.AutoFilterMode = False
    dws.UsedRange.Clear
    Dim dfcell As Range: Set dfcell = dws.Range(dFirst)
    Dim drg As Range: Set drg = dfcell.Resize(rCount, cCount) ' Table Range
    
    srg.Copy drg ' copy
    
    Dim ddrg As Range: Set ddrg = drg.Resize(rCount - 1).Offset(1) ' Data Range
    
    drg.AutoFilter dfField, dfCriteria
    
    Dim ddfrg As Range ' Data Filtered Range
    On Error Resume Next
        Set ddfrg = ddrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    dws.AutoFilterMode = False
    
    If Not ddfrg Is Nothing Then
        ddfrg.EntireRow.Delete ' delete 'empty' rows
    End If
    
    'drg.EntireColumn.AutoFit
    'wb.Save
    
    Application.ScreenUpdating = True
    
    MsgBox "Data copied.", vbInformation, "Copy Filtered Data"

End Sub

【讨论】：

过滤似乎是要走的路。就像导入的魅力一样。我永远不会想到这一点。非常感谢。
@VBasic2008 如果您的问题已解决，请不要忘记将其标记为已回答。 ;)

【解决方案2】：

下面的代码应该对你有所帮助。

Sub CopyNonEmptyData()
    
    Dim intSheet3Row As Integer
    intSheet3Row = 2
    
    For Each c In Range("A2:Q3500")
        If c.Value <> "" Then
            Sheets("Sheet3").Range("A" & intSheet3Row).Value = c.Value
            intSheet3Row = intSheet3Row + 1
        End If
    Next c
    
End Sub

【讨论】：