Excelmacros复制单行它不应该
我有一个macrosdevise用来将一行的内容复制到一个单独的工作表，根据包含在原始工作表中的一个button（包含在几个列中的一个中）：
Private Sub CommandButton1_Click() Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual Dim longLastRow As Long Dim Cancelled As Worksheet, Discontinued As Worksheet, NotConf24 As Worksheet, ESDout As Worksheet, NotConfShip As Worksheet, NotConfShip24 As Worksheet Set Cancelled = Sheets("Cancelled") Set Discontinued = Sheets("Discontinued") Set NotConf24 = Sheets("NotConfAvail24hr") Set ESDout = Sheets("ESDoutsideLeadtime") Set NotConfShipLead = Sheets("NotConfButShipInLead") Set NotConfShip24 = Sheets("NotConfShip24hrs") longLastRow = Cells(Rows.Count, "A").End(xlUp).Row With Range("A2", "T" & longLastRow) .AutoFilter .AutoFilter Field:=13, Criteria1:="Yes" .Copy Cancelled.Range("A1") .AutoFilter Field:=14, Criteria1:="Yes" .Copy Discontinued.Range("A1") .AutoFilter Field:=15, Criteria1:="No" .Copy NotConf24.Range("A1") .AutoFilter Field:=16, Criteria1:="Yes" .Copy NotConfShipLead.Range("A1") .AutoFilter Field:=18, Criteria1:="No" .Copy NotConfShip24.Range("A1") .AutoFilter End With Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic End Sub 我遇到的问题是将范围A2的第一行复制到每个工作表，即使它不符合条件。 我与VBA合作的经验很less。 我从这里得到了这个macros，并且阅读了大量与这种function有关的其他文章，尝试了许多提供的解决scheme，并且每次都做得很less。
在我上面链接的文章中，有一个用户有类似的问题（它只复制了范围中的第一行），并build议这可能是由于列A可能不包含实际最后一行的值内容; 然而，就我而言，它确实如此。 A和T之间A所有列都有一个值。
除此之外，这个macros很好用！ 能够在不到一秒的时间内sorting〜10,000行。
请试试这个：
Private Sub CommandButton1_Click() Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual Dim longLastRow As Long Dim Cancelled As Worksheet, Discontinued As Worksheet, NotConf24 As Worksheet, ESDout As Worksheet, NotConfShip As Worksheet, NotConfShip24 As Worksheet Set Cancelled = Sheets("Cancelled") Set Discontinued = Sheets("Discontinued") Set NotConf24 = Sheets("NotConfAvail24hr") Set ESDout = Sheets("ESDoutsideLeadtime") Set NotConfShipLead = Sheets("NotConfButShipInLead") Set NotConfShip24 = Sheets("NotConfShip24hrs") longLastRow = Cells(Rows.Count, "A").End(xlUp).Row Dim cpyRng As Range Set cpyRng = Range("A3", "T" & longLastRow) With Range("A2", "T" & longLastRow) .AutoFilter .AutoFilter Field:=13, Criteria1:="Yes" cpyRng.Copy Cancelled.Range("A1") .AutoFilter Field:=14, Criteria1:="Yes" cpyRng.Copy Discontinued.Range("A1") .AutoFilter Field:=15, Criteria1:="No" cpyRng.Copy NotConf24.Range("A1") .AutoFilter Field:=16, Criteria1:="Yes" cpyRng.Copy NotConfShipLead.Range("A1") .AutoFilter Field:=18, Criteria1:="No" cpyRng.Copy NotConfShip24.Range("A1") .AutoFilter End With Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic End Sub
你也可以改变cpyRng. 到.Offset(1).Resize(.Rows.Count - 1). 并通过这种方式跳过整个cpyRng -Variable …
不过，我相信这应该是一个简单快速的解决scheme:)
所以我使用了BruceWayne的build议，并在这里提供了关于启用自动filter来提出解决scheme的build议。 在和老板交谈之后，我们确定我们希望标题行总是被复制，这就是为什么你会看到范围已经改变了。
以下是我想到的：
Private Sub CommandButton1_Click() Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual Dim longLastRow As Long Dim AllData As Worksheet, Cancelled As Worksheet, Discontinued As Worksheet, NotConf24 As Worksheet, ESDout As Worksheet, NotConfShip As Worksheet, NotConfShip24 As Worksheet, NoTrack As Worksheet Set Cancelled = Sheets("Cancelled") Set Disco = Sheets("Discontinued") Set NotConf24 = Sheets("NotConfAvail24hr") Set ESDout = Sheets("ESDoutsideLeadtime") Set NotConfShipLead = Sheets("NotConfButShipInLead") Set NotConfShip24 = Sheets("NotConfShip24hrs") Set AllData = Sheets("All Data") Set NoTrack = Sheets("NoTracking") longLastRow = AllData.Cells(AllData.Rows.Count, "A").End(xlUp).Row With Range("A1", "T" & longLastRow) .AutoFilter .AutoFilter Field:=13, Criteria1:="Yes" .Copy Cancelled.Range("A1") .AutoFilter End With longLastRow = AllData.Cells(AllData.Rows.Count, "A").End(xlUp).Row With Range("A1", "T" & longLastRow) .AutoFilter .AutoFilter Field:=14, Criteria1:="Yes" .Copy Disco.Range("A1") .AutoFilter End With longLastRow = AllData.Cells(AllData.Rows.Count, "A").End(xlUp).Row With Range("A1", "T" & longLastRow) .AutoFilter .AutoFilter Field:=15, Criteria1:="No" .Copy NotConf24.Range("A1") .AutoFilter End With longLastRow = AllData.Cells(AllData.Rows.Count, "A").End(xlUp).Row With Range("A1", "T" & longLastRow) .AutoFilter .AutoFilter Field:=16, Criteria1:="Yes" .Copy NotConfShipLead.Range("A1") .AutoFilter End With longLastRow = AllData.Cells(AllData.Rows.Count, "A").End(xlUp).Row With Range("A1", "T" & longLastRow) .AutoFilter .AutoFilter Field:=17, Criteria1:="No" .Copy ESDout.Range("A1") .AutoFilter End With longLastRow = AllData.Cells(AllData.Rows.Count, "A").End(xlUp).Row With Range("A1", "T" & longLastRow) .AutoFilter .AutoFilter Field:=18, Criteria1:="No" .Copy NotConfShip24.Range("A1") .AutoFilter End With longLastRow = AllData.Cells(AllData.Rows.Count, "A").End(xlUp).Row With Range("A1", "T" & longLastRow) .AutoFilter .AutoFilter Field:=19, Criteria1:="No" .Copy NoTrack.Range("A1") .AutoFilter End With If Not ActiveSheet.AutoFilterMode Then ActiveSheet.Range("A1").AutoFilter End If Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic End Sub
这会正确地复制正确的行，包括标题行，并确保filter不会从AllData的标题行中剥离。
重复longLastRow并将.AutoFilter和.Copy函数分离成单独的块可能不是必需的，但是它可以工作，而且我不想再为了再次打破它而.Copy它。
感谢大家的帮助和build议！