根据自动过滤的列复制列，然后仅将值粘贴到该自动过滤的列

Question

我想根据“未知”等值过滤列B，然后过滤L列以获得非空值。 复制L列。 仅将值粘贴到B列。

Before:
ColumnB ..... Column L
1 ..... a
2 ..... b
Unknown.c
3.......d
Unknown.e
Unknown.

After
1 ..... a
2 ..... b
c.......c
3.......d
e.......e
Unknown..

    Set r1 = Range("B:B").SpecialCells(xlCellTypeVisible)
    Set r2 = Range("L:L").SpecialCells(xlCellTypeVisible)
    Set myMultipleRange = Union(r1, r2)
    Application.ScreenUpdating = False
    sh1.Range("B:L").AutoFilter
    sh1.Range("B:B").AutoFilter Field:=1, Criteria1:="Unknown", Operator:=xlFilterValues

    sh1.Range("L:L").AutoFilter Field:=11, Operator:=xlFilterValues, Criteria1:="<>"

    LstRw = sh1.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
    If LstRw <> 0 Then
        myMultipleRange.FillLeft
    End If

上面的代码将复制和粘贴，包括格式。

Answer 1

复制/粘贴过滤表并不是一个好主意，因为它甚至会在隐藏的行中连续插入数据并混乱您的数据。

我推荐以下内容：

• 过滤数据
• 遍历所有可见单元格并逐行复制数据

如果给出以下数据......

...并且您想要用L列中的数据替换unkown ，您可以执行以下操作：

Option Explicit

Public Sub FilterAndCopy()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Tabelle1")

    'Filter data
    ws.Range("B:B").AutoFilter Field:=1, Criteria1:="Unknown", Operator:=xlFilterValues

    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

    Dim DestinationRange As Range
    On Error Resume Next 'next line throws error if filter returns no data rows
    Set DestinationRange = ws.Range("B2", "B" & LastRow).SpecialCells(xlCellTypeVisible) 'find visible cells between B2 (exclude header) and last row in B
    On Error GoTo 0 'always re-activate error reporting!

    If Not DestinationRange Is Nothing Then 'do it only if there is visible data
        Dim Cell As Range
        For Each Cell In DestinationRange 'copy each value row wise
            Cell.Value = Cell.Offset(ColumnOffset:=10).Value 'column L is 10 columns right of B
        Next Cell
    End If
End Sub

Answer 2

替代解决方案 - 只需遍历B列中的每个单元格，并将“Unknown”替换为L列中的相应值。

Sub foo()
    Dim lngLastRow          As Long
    Dim rngCell             As Range

    With Sheet1
        LastRow = .Range("B" & Rows.Count).End(xlUp).Row
        For Each rngCell In .Range("B1:B" & LastRow)
            If rngCell.Value = "Unknown" Then
                rngCell.Value = .Range("L" & rngCell.Row).Value
            End If
        Next rngCell
    End With
End Sub

PS确保With Sheet1相关的工作表名称/代码替换With Sheet1语句。