Excel 宏复制单行它不应该

Question

我有一个宏，旨在通过单击按钮将一行的内容复制到单独的 sheet，该值基于多个列之一中包含的值，该按钮包含在原始 sheet:

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 复制到每个 sheet，即使它不符合条件。我使用 VBA 的经验很少。我从 here 获得了这个宏，并仔细阅读了大量与此类功能相关的其他文章，尝试了所提供的许多解决方案，但每次都失败了。

在我上面链接的 post 中，一位用户遇到了类似的问题（它只复制了范围内的第一行），有人认为这可能是由于列 A 可能不包含实际最后一行内容的值；但是，就我而言，确实如此。 A 和 T 之间的所有列都有一个值。

除此之外，这个宏非常有用！能够在不到一秒的时间内对约 10,000 行进行排序。

Answer 1

请试试这个：

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-变量...

不过，我确信这应该是一个简单快速的解决方案:)

Answer 2

所以我使用了 BruceWayne 的建议和关于启用自动过滤器的提示 here 来提出一个最终运行良好的解决方案。在与我的老板交谈后，确定我们希望始终复制 header 行，这就是为什么您会看到范围已更改的原因。

这是我想出的：

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

这会正确复制正确的行，包括 header 行，并确保过滤器不会从 AllData 中的 header 行中删除。

重复 longLastRow 并将 .AutoFilter 和 .Copy 函数分成单独的块可能没有必要，但它有效，我不想因为害怕而弄乱它再次打破它。

感谢大家的帮助和建议！

Excel 宏复制单行它不应该

Excel Macro Copying A Single Row It Shouldn't

excel

vba

excel-2013