Vba 有一个工作Excel宏，需要帮助调整它吗

我有一个宏，它可以很好地将行复制到另一个工作表。我想对它做一些调整，但我不确定如何做

1） 我想把它复制到新的工作表上

2） 有没有办法简化“如果范围”（“G”&r”）.Value=“46704”或“范围”部分？比如用逗号或别的什么来列出它们

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

---

您可以尝试将以下代码复制到新工作表：

Set ws2 = Sheets.Add After:=Sheets(Sheets.Count)

此外，您需要在此处引用工作表范围（“G”&r）.Value

---

希望有帮助。

这里是一个使用

AutoFilter（）的简化版本。

---

---

您可以使用case语句

Option Explicit

Sub Allen()
    Dim lr1 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
    lr1 = ws1.Cells(Rows.Count, "G").End(xlUp).Row
    lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
        For r = 2 To lr1
            Select Case CDec(Range("G" & r).Value) - 46000      ' convert to number and subtract 46000 to make lookup list smaller

                Case 704, 741, 743, 745, 748, 765, 773, 774, _
                     788, 797, 798, 799, 801, 802, 803, 804, _
                     805, 806, 807, 808, 809, 814, 815, 816, _
                     818, 819, 825, 835, 845, 850, 851, 852, _
                     853, 854, 855, 856, 857, 858, 859, 860, _
                     861, 862, 863, 864, 865, 866, 867, 868, _
                     869, 885, 895, 896, 897, 898, 899

                    Rows(r).Copy Destination:=ws2.Range("A" & n + 1)
                    n = ws2.Cells(Rows.Count, "A").End(xlUp).Row
            End Select
        Next r
    Application.ScreenUpdating = True
End Sub

---

这是一个仅使用范围对象（不计算行）的对象

---

我想将其复制到新工作表中

看起来您已经在复制到新工作表中了。或者您指的是一个新的Excel文档？您希望的

If范围（“G”&r）…

行是什么？您不会像以后那样在那里引用工作表

ws.Cells（）

。。。还有，

46704

。。。都在一个范围内吗？可能只是

If[range]>=46704和[range]No，不幸的是，这些是一组特定的唯一值。
If
语句可能作为
If InStr（“| 46704 | 46741 | 46743 |…”46898 | 46899 |“，“|”&ws1.range（“G”&r）.Value&“|”）0那么
）。（我假设您正在检查的值来自
“Sheet1”
，基于对r=2到lr的
使用，其中
lr
是
“Sheet1”
上G列的行数）已经提出的许多建议都超出了我的理解范围，但我正在努力学习和实施它们。谢谢您的建议。
Rows（r）
也应该是
ws1.Rows（r）
，和
lr=ws1.Cells（Rows.Count，“G”）.End（xlUp）。Row
应该是
lr=ws1.Cells（ws1.Rows.Count，“G”）.End（xlUp）。Row
和
ws2.Cells.Count，“A”）.End（xlUp）。Row
应该是
ws2.Cells（ws2.Rows.Count，“A”）.End（xlUp）.Row
。我实现了案例部分，并使其正常工作。非常感谢您的输入。我正在努力实现部分版本。它工作得很好。谢谢我想做的事情是把它复制到一个新的工作簿上。可能吗？p、 我知道我在原来的帖子中说的是工作表，我指的是工作簿。我更新了
AllenAutoFilter（）
以将数据复制到新工作簿。每次运行它时，您都会得到一个新文件（位于初始文件之后），通常称为Book2、Book3等
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

Option Explicit

Sub Allen()
    Dim lr1 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
    lr1 = ws1.Cells(Rows.Count, "G").End(xlUp).Row
    lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
        For r = 2 To lr1
            Select Case CDec(Range("G" & r).Value) - 46000      ' convert to number and subtract 46000 to make lookup list smaller

                Case 704, 741, 743, 745, 748, 765, 773, 774, _
                     788, 797, 798, 799, 801, 802, 803, 804, _
                     805, 806, 807, 808, 809, 814, 815, 816, _
                     818, 819, 825, 835, 845, 850, 851, 852, _
                     853, 854, 855, 856, 857, 858, 859, 860, _
                     861, 862, 863, 864, 865, 866, 867, 868, _
                     869, 885, 895, 896, 897, 898, 899

                    Rows(r).Copy Destination:=ws2.Range("A" & n + 1)
                    n = ws2.Cells(Rows.Count, "A").End(xlUp).Row
            End Select
        Next r
    Application.ScreenUpdating = True
End Sub

Option Explicit

Sub test()

    Application.ScreenUpdating = False

    Dim ws1 As Worksheet
    Set ws1 = Sheets("Sheet1")

    Dim ws2 As Worksheet
    Set ws2 = Sheets("Sheet2")

    Dim lr1 As Range
    Set lr1 = Range(ws1.Cells(2, "G"), ws1.Cells(Rows.Count, "G").End(xlUp))

    Dim lr2 As Range
    Set lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1) ' point to next empty cell

    Dim r As Range
    For Each r In lr1

        Select Case CDec(r.Value) - 46000   ' convert to number and subtract 46000 to make lookup list smaller

            Case 704, 741, 743, 745, 748, 765, 773, 774, _
                 788, 797, 798, 799, 801, 802, 803, 804, _
                 805, 806, 807, 808, 809, 814, 815, 816, _
                 818, 819, 825, 835, 845, 850, 851, 852, _
                 853, 854, 855, 856, 857, 858, 859, 860, _
                 861, 862, 863, 864, 865, 866, 867, 868, _
                 869, 885, 895, 896, 897, 898, 899

                r.EntireRow.Copy Destination:=lr2
                Set lr2 = lr2.Offset(1)              ' point to next empty cell
        End Select

    Next r

    Application.ScreenUpdating = True

End Sub