在范围内搜索非空单元格，粘贴到新 sheet

Question

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

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

当我说“精确值”时，我的意思是单元格中的 text/number 与复制时显示的完全相同，没有应用不同的格式。

任何指导将不胜感激，谢谢！

Answer 1

下面的代码应该能帮到你。

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

Answer 2

复制过滤后的数据

以下将复制完整的 table 范围，然后删除 'empty' 行。
调整常量部分中的值。

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

在范围内搜索非空单元格，粘贴到新 sheet

Search for not empty cells in range, paste to new sheet

excel

vba

copy-paste

autofilter

复制过滤后的数据