Filter messes with VBA

[Rob_010101]

Hello,

I am using the below code, which moves a row to another sheet based upon the value of a drop-down list item.

However, if the data on the sheet the row is moving to is filtered, instead of adding the copied row to the first blank row at the bottom of the data, it overwrites a row of data next in the list. For example, when filtering on Chester, it will overwrite the first row of data where the location is Doncaster, instead of adding the data to the first blank row right at the bottom of the data.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim fromRow%, archiveRow%, archiveList As Worksheet
    If Target.Cells.Count > 1 Then Exit Sub
   
    If Not Application.Intersect(Target, Range("O2:O500000")) Is Nothing Then 'amend this range address to your
        Set archiveList = ThisWorkbook.Worksheets("Archive")
            If Target.Value = "Archive" Then
                fromRow = ActiveCell.Row
                archiveRow = archiveList.Cells(archiveList.Rows.Count, 1).End(3).Row + 1
                Range(Cells(fromRow, 1), Cells(fromRow, 15)).Copy archiveList.Cells(archiveRow, 1)
                Rows(fromRow).EntireRow.Delete
            End If
    End If
End Sub

Wondering if someone might know how to get the above to ignore a filter.

Kind Regards
Chris

 

[Alex Blakenburg]

Yes looks right. Let me know how you go.

 

[Rob_010101]

 

[Alex Blakenburg]

Sorry I only focused on what I changed, you lost some of the original code lines off the bottom.
You are missing everything after the End With.
This should be the full code. Maybe comment out the delete rows line while you are testing.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim fromRow%, archiveRow%, archiveList As Worksheet

    If Target.Cells.Count > 1 Then Exit Sub
  
    If Not Application.Intersect(Target, Range("O2:O500000")) Is Nothing Then 'amend this range address to your
        Set archiveList = ThisWorkbook.Worksheets("Archive")
            If Target.Value = "Archive" Then
                fromRow = ActiveCell.Row
               
                With archiveList
                    If .FilterMode Then
                        Dim strMatch As String
                        strMatch = "match" & Replace("(2,1/(a:a>""""),1)", "a:a", .AutoFilter.Range.Cells(1).EntireColumn.Address(0, 0, 1, 1))
                        archiveRow = Evaluate(strMatch) + 1
                    Else
                        archiveRow = archiveList.Cells(archiveList.Rows.Count, 1).End(3).Row + 1
                    End If
                End With
               
                Range(Cells(fromRow, 1), Cells(fromRow, 15)).Copy archiveList.Cells(archiveRow, 1)
                Rows(fromRow).EntireRow.Delete
            End If
    End If
End Sub

 

[Rob_010101]

Sorry I only focused on what I changed, you lost some of the original code lines off the bottom.
You are missing everything after the End With.
This should be the full code. Maybe comment out the delete rows line while you are testing.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim fromRow%, archiveRow%, archiveList As Worksheet

    If Target.Cells.Count > 1 Then Exit Sub
 
    If Not Application.Intersect(Target, Range("O2:O500000")) Is Nothing Then 'amend this range address to your
        Set archiveList = ThisWorkbook.Worksheets("Archive")
            If Target.Value = "Archive" Then
                fromRow = ActiveCell.Row
              
                With archiveList
                    If .FilterMode Then
                        Dim strMatch As String
                        strMatch = "match" & Replace("(2,1/(a:a>""""),1)", "a:a", .AutoFilter.Range.Cells(1).EntireColumn.Address(0, 0, 1, 1))
                        archiveRow = Evaluate(strMatch) + 1
                    Else
                        archiveRow = archiveList.Cells(archiveList.Rows.Count, 1).End(3).Row + 1
                    End If
                End With
              
                Range(Cells(fromRow, 1), Cells(fromRow, 15)).Copy archiveList.Cells(archiveRow, 1)
                Rows(fromRow).EntireRow.Delete
            End If
    End If
End Sub

For some reason, even though I deleted the formula and physically checked all the rows (and they were definitely blank this time), it still wanted to select up to row 9980 when pressing Ctrl+A. So, before running your code, I highlighted and deleted all the blank rows up to 9980 and it then selected up to the correct last blank row (520) this time. I can only assume that there was some corruption in the sheet that caused this??

Anyway, your code works both filtered and unfiltered.

Thank you so much for your effort - and thank you Jason also.

 

[Alex Blakenburg]

I haven't tested it but I imagine that Autofilter is closely tied to UsedRange. UsedRange will not reset until you hit Save on the spreadsheet (or execute a UsedRange command in the code.)
Try hitting save and then try the Ctrl + A test again (or Ctrl+<*>).

Glad it worked for you and that @jasonb75 and I were able to help.