Question

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

1）我希望将其复制到新的工作表中。

2）有没有办法简化＆＃34; If范围（＆＃34; G＆＃34;＆amp; r）.Value =＆＃34; 46704＆＃34;或＆＃34;部分？喜欢用逗号或其他东西列出它们吗？

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

Answer 2

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

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

此外，您需要在此处引用工作表范围（＆＃34; G＆＃34;＆amp; r）.Value

ws1.Range("G" & r).Value

希望得到这个帮助。

Answer 3

您可以使用案例陈述

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

Answer 4

这里只使用范围对象（没有计数行）

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

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

4 个答案: