Filtering and moving data with VBA

user_17130648 0
Viewed 48

I am trying to find a way to quickly filter and cut range of cell's to another sheet

to be precise :

Private Sub CommandButton1_Click()

Dim rng As Range, cell As Range

Set rng = Range("a2:a100")

For Each cell In rng

If Sheet1.Range("a2").Offset(1) = "DE" Then
Sheet1.Range("b2:f2").Cut Sheet2.Range("b2:f2")

End If
Next cell
End Sub

i know that this code is just limited to Cell(A2).

I need my code to go trough Range ("a2:a100") and if it contains value Exp. "DE" to cut range(b2:f2) to the next sheet

EXP.

If cell a2 contains "DE" it need's to cut range ("b2:f2") If cell a5 contains "DE" it need's to cut range ("b5:f5") exc...

navbar vba excel
2 Answers

If you NEED to cut and paste, fine, just be aware you will need to select the paste destination sheet, and then the source sheet again afterwards. However, if you're only interested in the cell contents, just "transferring" values is simpler and (much) faster, and as follows.

Private Sub CommandButton1_Click()

Dim rng As Range, cell As Range
Dim TargetRow As Long

Set rng = Range("a2:a100")

    For Each cell In rng
        If cell = "DE" Then
            TargetRow = cell.Row
            Worksheets("Sheet2").Range("B" & TargetRow & ":F" & TargetRow).Value2 = Worksheets("Sheet1").Range("B" & TargetRow & ":F" & TargetRow).Value2
            Worksheets("Sheet1").Range("B" & TargetRow & ":F" & TargetRow).ClearContents
        End If
    Next cell
    
End Sub
user_36543250

Cut Criteria Row (For Each...Next)

  • Using arrays or using AutoFilter will surely be more efficient.
Option Explicit

Sub CutCriteriaRows()
    
    Const sCol As String = "A"
    Const sdCols As String = "B:F"
    Const sfRow As Long = 2
    Const sCriteria As String = "DE"
    
    Const dCol As String = "B"
    
    Dim sws As Worksheet: Set sws = Sheet1
    Dim dws As Worksheet: Set dws = Sheet2
    
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, sCol).End(xlUp).Row
    Dim srCount As Long: srCount = slRow - sfRow + 1
    
    Dim srg As Range: Set srg = sws.Cells(sfRow, sCol).Resize(srCount)
    
    Dim scrg As Range
    Dim sCell As Range

    For Each sCell In srg.Cells
        If CStr(sCell) = sCriteria Then
            Set scrg = RefCombinedRange(scrg, sCell)
        End If
    Next sCell
    
    If scrg Is Nothing Then Exit Sub
    
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Row
    Dim dfCell As Range: Set dfCell = dws.Cells(dlRow + 1, dCol)
    
    With Intersect(scrg.EntireRow, sws.Columns(sdCols))
        .Copy dfCell
        .EntireRow.Delete
    End With

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
    ByVal CombinedRange As Range, _
    ByVal AddRange As Range) _
As Range
    If CombinedRange Is Nothing Then
        Set RefCombinedRange = AddRange
    Else
        Set RefCombinedRange = Union(CombinedRange, AddRange)
    End If
End Function
user_98140690
Related