CODEWITHSUNDEEP
vbaexcelexcel-2013
HindenPeter
HindenPeter

Reputation: 23

Excel Macro Copying A Single Row It Shouldn't

I have a macro designed to copy a row's contents to a separate sheet based on a value contained in one of several columns with the click of a button, which is contained on the originating 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

The problem I'm having is it's copying the first row in the range, A2, to every sheet even if it doesn't meet the criteria. I have very little experience working with VBA. I got this macro from here and have perused a significant number of other articles pertaining to this type of function, have tried many of the solutions offered, and have come up short each time.

In the post I linked above, one user had a similar problem (it ONLY copied the first row in the range), and it was suggested that it could be due to the fact that column A might not contain a value on the actual last row with content; however, in my case it does. All columns between A and T have a value.

Other than that, this macro works great! Able to sort ~10,000 rows in less than a second.

Upvotes: 1

Views: 154

Answers (2)

HindenPeter
HindenPeter

Reputation: 23

So I used suggestions from BruceWayne and a hint here regarding enabling auto filter to come up with a solution that ended up working really well. After speaking with my boss, it was determined that we want the header row to always be copied, which is why you'll see the range has changed.

Here's what I came up with:

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

This copies the correct rows properly, including the header row, and ensures that the filters aren't stripped from the header row in AllData.

Repeating longLastRow and separating the .AutoFilter and .Copy functions into individual blocks may not be necessary, but it works, and I don't want to mess with it for fear of breaking it again.

Thanks to everyone for their help and suggestions!

Upvotes: 0

Dirk Reichel
Dirk Reichel

Reputation: 7979

Pls try this:

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

You also could change the cpyRng. to .Offset(1).Resize(.Rows.Count - 1). and skip out the whole cpyRng-Variable this way...

Still, I'm sure that this should be a easy fast solution :)

Upvotes: 1

Related Questions