有一个工作的Excelmacros，需要帮助调整它

我有这个macros可以很好地将行复制到另一个工作表。 有一些我想做的调整，但我不知道如何。

1）我想把它复制到一个新的工作表。

2）有没有办法简化“If Range（”G“＆r）.Value =”46704“或”section？ 像用逗号或其他东西列出他们？

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) 

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

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

希望这个帮助。

Answer 3

你可以使用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 

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