vba - 有一个有效的 Excel 宏，需要帮助调整它

Question

我有这个宏可以很好地将行复制到另一张纸上。我想对其进行一些调整，但我不确定如何做。

1)我想让它复制到一个新的工作表。

2) 有没有办法简化 "If Range("G"& r).Value = "46704"Or"部分？喜欢用逗号或其他东西列出它们吗？

Sub Allen()
Dim lr As Long, lr2 As Long, r As Long, ws1 As Worksheet, ws2 As Worksheet, n As Long
Application.ScreenUpdating = False
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
n = 2
lr = ws1.Cells(Rows.Count, "G").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
    For r = 2 To lr
    If Range("G" & r).Value = "46704" Or Range("G" & r).Value = "46741" Or Range("G" & r).Value = "46743" Or Range("G" & r).Value = "46745" Or Range("G" & r).Value = "46748" Or Range("G" & r).Value = "46765" Or Range("G" & r).Value = "46773" Or Range("G" & r).Value = "46774" Or Range("G" & r).Value = "46788" Or Range("G" & r).Value = "46797" Or Range("G" & r).Value = "46798" Or Range("G" & r).Value = "46799" Or Range("G" & r).Value = "46801" Or Range("G" & r).Value = "46802" Or Range("G" & r).Value = "46803" Or Range("G" & r).Value = "46804" Or Range("G" & r).Value = "46805" Or Range("G" & r).Value = "46806" Or Range("G" & r).Value = "46807" Or Range("G" & r).Value = "46808" Or Range("G" & r).Value = "46809" Or Range("G" & r).Value = "46814" Or Range("G" & r).Value = "46815" Or Range("G" & r).Value = "46816" Or Range("G" & r).Value = "46818" Or Range("G" & r).Value = "46819" Or Range("G" & r).Value = "46825" Or Range("G" & r).Value = "46835" Or Range("G" & r).Value = "46845" _
        Or Range("G" & r).Value = "46850" Or Range("G" & r).Value = "46851" Or Range("G" & r).Value = "46852" Or Range("G" & r).Value = "46853" Or Range("G" & r).Value = "46854" Or Range("G" & r).Value = "46855" Or Range("G" & r).Value = "46856" Or Range("G" & r).Value = "46857" Or Range("G" & r).Value = "46858" Or Range("G" & r).Value = "46859" Or Range("G" & r).Value = "46860" Or Range("G" & r).Value = "46861" Or Range("G" & r).Value = "46862" Or Range("G" & r).Value = "46863" Or Range("G" & r).Value = "46864" Or Range("G" & r).Value = "46865" Or Range("G" & r).Value = "46866" Or Range("G" & r).Value = "46867" Or Range("G" & r).Value = "46868" Or Range("G" & r).Value = "46869" Or Range("G" & r).Value = "46885" Or Range("G" & r).Value = "46895" Or Range("G" & r).Value = "46896" Or Range("G" & r).Value = "46897" Or Range("G" & r).Value = "46898" Or Range("G" & r).Value = "46899" Then
            Rows(r).Copy Destination:=ws2.Range("A" & n + 1)
            n = ws2.Cells(Rows.Count, "A").End(xlUp).Row
        End If
    Next r
Application.ScreenUpdating = True
End Sub

Answer 1

这是使用 的简化版本AutoFilter()

Public Sub AllenAutoFilter()
   Const SET1 = "46704,46741,46743,46745,46748,46765,46773,46774,46788,46797,46798,46799,"
   Const SET2 = "46801,46802,46803,46804,46805,46806,46807,46808,46809,46814,46815,46816,"
   Const SET3 = "46818,46819,46825,46835,46845,46850,46851,46852,46853,46854,46855,46856,"
   Const SET4 = "46857,46858,46859,46860,46861,46862,46863,46864,46865,46866,46867,46868,"
   Const SET5 = "46869,46885,46895,46896,46897,46898,46899"
   Const ALL = SET1 & SET2 & SET3 & SET4 & SET5

   Dim ws1 As Worksheet, ws2 As Worksheet, lr1 As Long, lr2 As Long, arr As Variant

    arr = Split(ALL, ",")
    Application.ScreenUpdating = False
    With ThisWorkbook
        Set ws1 = .Worksheets("Sheet1")
        Set ws2 = Workbooks.Add.Worksheets(1)    'New Workbook, Sheet1
    End With

    ws1.AutoFilterMode = False
    lr1 = ws1.Cells(Rows.Count, "G").End(xlUp).Row
    lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1

    With ws1.UsedRange
        .Columns(7).AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues
        .Offset(1).Resize(lr1 - 1).Rows.Copy Destination:=ws2.Range("A" & lr2)
    End With
    ws1.AutoFilterMode = False

    ws1.Activate
    Application.ScreenUpdating = True
End Sub