用于列出名称的VBA宏代码

Question

我有一张Excel表格,其名称为一列,其工作时间为下一栏中的值.

我想将值大于40的名称复制到新工作表而列中没有任何空格.新表应具有名称和工作时间; 应忽略值列中的任何文本.

Sub CopyCells()
    Dim sh1 As Worksheet, sh2 As Worksheet 
    Dim j As Long, i As Long, lastrow1 As Long 

    Set sh1 = Worksheets("Sheet1") 
    Set sh2 = Worksheets("Sheet2") 
    lastrow1 = sh1.Cells(Rows.Count, "F").End(xlUp).Row 

    For i = 1 To lastrow1 
        If sh1.Cells(i, "F").Value > 20 Then 
            sh2.Range("A" & i).Value = sh1.Cells(i, "F").Value 
        End If 
    Next i 
End Sub

Answer 1

我建议使用AutoFilter复制和粘贴,因为它比循环更快.请参阅下面的示例.

我的假设

1. 原始数据位于工作表1中,如下面的快照所示
2. 您需要Sheet 2中的输出,如下面的快照所示

代码(经过试验和测试)

我已对代码进行了评论,以便您在理解代码时不会遇到任何问题.

Option Explicit

Sub Sample()
    Dim wsI As Worksheet, wsO As Worksheet
    Dim lRow As Long

    '~~> Set the input sheet
    Set wsI = Sheets("Sheet1"): Set wsO = Sheets("Sheet2")

    '~~> Clear Sheet 2 for output
    wsO.Cells.ClearContents

    With wsI
        '~~> Remove any existing filter
        .AutoFilterMode = False

        '~~> Find last row in Sheet1
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        '~~> Filter Col B for values > 40
        With .Range("A1:B" & lRow)
            .AutoFilter Field:=2, Criteria1:=">40"
            '~~> Copy the filtered range to Sheet2
            .SpecialCells(xlCellTypeVisible).Copy wsO.Range("A1")
        End With

        '~~> Remove any existing filter
        .AutoFilterMode = False
    End With

    '~~> Inform user
    MsgBox "Done"
End Sub

快照