Question

我有一个宏，用于将行的内容复制到一个单独的工作表中，该工作表基于包含在多个列之一中的值，只需单击一个按钮，该按钮包含在原始工作表中：

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方面经验很少。我从here获得了这个宏，并且已经阅读了大量关于这类函数的其他文章，尝试了许多提供的解决方案，并且每次都做得很短。

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

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

Answer 1

请试试这个：

image_instance

您也可以将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). - 以这种方式变量......

尽管如此，我确信这应该是一个简单快速的解决方案：）

Answer 2

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

这是我想出的：

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

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

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

感谢大家的帮助和建议！

Excel宏复制单行它不应该

2 个答案: