CODEWITHSUNDEEP
vbaexcel
Eric
Eric

Reputation: 11

VBA Dynamic Filtering and Copy Paste into new worksheet

I am trying to write a vba script that will filter on two columns, column A and column D. Preferably, I want to create a button that will execute once I have chosen the filter criteria. Sample of input data below.

 Sub Compiler()
  Dim i
  Dim LastRow As Integer

  LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row

  Sheets("Sheet4").Range("A2:J6768").ClearContents

     For i = 2 To LastRow
          If Sheets("Sheet1").Cells(i, "A").Values = Sheets("Sheet3").Cells(3, "B").Values And Sheets("Sheet1").Cells(i, "D").Values = Sheets("Sheet3").Cells(3, "D").Values Then
             Sheets("Sheet1").Cells(i, "A" & "D").EntireRow.Copy Destination:=Sheets("Sheet4").Range("A" + Rows.Count).End(xlUp)
          End If
     Next i

End Sub

Sample Data to run vba script

Upvotes: 0

Views: 1074

Answers (3)

Eric
Eric

Reputation: 11

This answered the question I was asking, I tried to work with Dan's answer but didn't get very far. 

Private Sub CommandButton1_Click()
FinalRow = Sheets("Sheet1").Cells(rows.Count, 1).End(xlUp).Row

Sheets("Sheet4").Range(Sheets("Sheet4").Cells(1, "A"), Sheets("Sheet4").Cells(FinalRow, "K")).ClearContents

If Sheets("Sheet4").Cells(1, "A").Value = "" Then
Sheets("Sheet1").Range("A1:K1").Copy
Sheets("Sheet4").Range(Sheets("Sheet4").Cells(1, "A"), Sheets("Sheet4").Cells(1, "K")).PasteSpecial (xlPasteValues)
End If

For x = 2 To FinalRow
    ThisValue = Sheets("Sheet1").Cells(x, "A").Value
    ThatValue = Sheets("Sheet1").Cells(x, "D").Value
    If ThisValue = Sheets("Sheet3").Cells(3, "B").Value And ThatValue = Sheets("Sheet3").Cells(3, "D").Value Then
    Sheets("Sheet1").Range(Sheets("Sheet1").Cells(x, 1), Sheets("Sheet1").Cells(x, 11)).Copy
    Sheets("Sheet4").Select
    NextRow = Sheets("Sheet4").Cells(rows.Count, 1).End(xlUp).Row + 1
    With Sheets("Sheet4").Range(Sheets("Sheet4").Cells(NextRow, 1), Sheets("Sheet4").Cells(NextRow, 11))
    .PasteSpecial (xlPasteFormats)
    .PasteSpecial (xlPasteValues)
    End With

    End If

    Next x

Worksheets("Sheet4").Cells.EntireColumn.AutoFit



End Sub

Upvotes: 0

Dan
Dan

Reputation: 435

I have included my previous answer's changes into the full code block that is now provided below.

Sub Compiler()
 Dim i
 Dim LastRow, Pasterow As Integer
 Dim sht As Worksheet

   Set sht = ThisWorkbook.Sheets("Sheet4")

   LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row

  Sheets("Sheet4").Range("A2:J6768").ClearContents

    For i = 2 To LastRow
        If Sheets("Sheet1").Range("A" & i).Value = Sheets("Sheet3").Range("B3").Value And Sheets("Sheet1").Range("D" & i).Value = Sheets("Sheet3").Range("D3").Value Then
           Pasterow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1
           Sheets("Sheet1").Rows(i).EntireRow.Copy Destination:=Sheets("Sheet4").Range("A" & Pasterow)
        End If
     Next i

 Sheets("sheet4").Rows(1).Delete

End Sub

Upvotes: 1

findwindow
findwindow

Reputation: 3153

Sheets("Sheet1").Cells(i, "A").Values
Sheets("Sheet3").Cells(3, "B").Values

etc

You keep using values. Don't you mean value?

Upvotes: 0

Related Questions