Filter and copy to another table with some extras

jocker_boy

New Member
Joined
Feb 5, 2015
Messages
35
Hello everyone,

I will try to explain my goal.

Sheet1
Header 1Header 2Header 3Header 4Header 5
AAACCCEEEHHH5
AAADDDFFFIII9
BBBDDDGGGHHH10
...............

Sheet2
Header 1Header 2Header 6Header 7Header 8Header 9
Filter 1Filter 2TEXT 1TEXT 2New / DeleteNumber 1, 2, 3, 4....

Sheet3
Header 1Header 2Header 3Header 4Header 6Header 7Header 5=Header 9 (1)Header 5=Header 9 (2)Header 5=Header 9 (3)
AAACCCEEEHHHTEXT 1TEXT 25
AAADDDFFFIIITEXT 1TEXT 29
BBBDDDGGGHHHTEXT 1TEXT 210
............

In Sheet 1 i have my Database, with multiple rows.
In Sheet 2, i choose "Filter 1" and "Filter 2", to filter the table in sheet 1 in "Header 1" and "Header 2".
In Sheet 2 i insert "Text 1", "Text 2", "Number 1" and choose "New or Delete"

If "New" it will sort using "Filter 1" and "Filter 2" and copy the table from "sheet 1" to the table in "sheet 3"

The dificult part is "Header 5" and "Header 9".
In sheet 2, in "Header 9" i will choose a number, "1", or "2", or "3", or more.

If "1" the values from "Header 5" will be copy to "Header 5=Header 9 (1)"
If "2" the values from "Header 5" will be copy to "Header 5=Header 9 (2)"
If "3" the values from "Header 5" will be copy to "Header 5=Header 9 (3)"
and so on...

If "Delete" it will sort using "Filter 1", "Filter 2", "Header 6", "Header 7 and "Header 9"" in table of "sheet 3" and delete those values.

Many thanks to all help.
Sorry to be so "complicated" to explain.

I have already this codes, but it is not perfect:

VBA Code:
Sub Filter()
    Dim sistema As Range, tipo As Range
  
    With Worksheets("sheet2")
        Set sistema = .Range("A2")
        Set tipo = .Range("B2")
    End With

    With Worksheets("Sheet1")
        With .Range("A1:I" & getlastrow)
            .AutoFilter 'Turn off any previous filtering
            .AutoFilter field:=1, Criteria1:=sistema
            .AutoFilter field:=2, Criteria1:=tipo
        End With
    End With
          
End Sub

Sub CopyPaste()
  
Set ws = ThisWorkbook.Worksheets("sheet3")
ws.Activate
  
Dim NextRow As Range
Set NextRow = Range("A" & Sheets("sheet3").UsedRange.Rows.Count + 1)
Sheets("Sheet1").Select
    With ActiveSheet.ListObjects("Table1").Range
        .Offset(1, 0).Resize(.Rows.Count - 1).Select
        Selection.Copy
    End With

Sheets("sheet3").Select
NextRow.PasteSpecial Paste:=xlValues, Transpose:=False
Application.CutCopyMode = False
Set NextRow = Nothing

End Sub

Sub Location()
    With Sheets("sheet3")
        .Range("E:E").SpecialCells(xlBlanks).Value = Sheets("sheet2").Range("C2").Value
        .Range("F:F").SpecialCells(xlBlanks).Value = Sheets("sheet2").Range("D2").Value
     End With
End Sub

Function getlastrow() As Integer
    Dim i As Integer
    getlastrow = 0
    With Worksheets("Sheet1")
        For i = 0 To 3
            'starting with 2+i=2 (column B) and End with 2+i=5 (column E)
            If (.Cells(.Rows.Count, 2 + i).End(xlUp).Row) > getlastrow Then
                getlastrow = .Cells(.Rows.Count, 2 + i).End(xlUp).Row
            End If
        Next i
    End With
End Function

Sub Delete()

'Apply a filter to a Range and delete visible rows
'Source: https://www.excelcampus.com/vba/delete-rows-cell-values/

Dim ws As Worksheet
Dim sistema As Range, Nome As Range, spot As Range

    With Worksheets("sheet2")
        Set sistema = .Range("A2")
        Set Nome = .Range("B2")
        Set spot = .Range("C2")
        Set other = .Range("D2")
    End With

  'Set reference to the sheet in the workbook.
  Set ws = ThisWorkbook.Worksheets("sheet3")
  ws.Activate 'not required but allows user to view sheet if warning message appears
 
  'Clear any existing filters
  On Error Resume Next
    ws.ShowAllData
  On Error GoTo 0

  '1. Apply Filter
  With Worksheets("sheet3")
        With .Range("A1:J1000")
            .AutoFilter 'Turn off any previous filtering
            .AutoFilter field:=1, Criteria1:=sistema
            .AutoFilter field:=2, Criteria1:=Nome
            .AutoFilter field:=5, Criteria1:=spot
            .AutoFilter field:=6, Criteria1:=other
        End With
    End With
   
      
  '2. Delete Rows
  Application.DisplayAlerts = False
    ws.Range("A2:J1000").SpecialCells(xlCellTypeVisible).Delete
  Application.DisplayAlerts = True
 
  '3. Clear Filter
  On Error Resume Next
    ws.ShowAllData
  On Error GoTo 0

End Sub
 
Last edited:

Some videos you may like

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.

Watch MrExcel Video

Forum statistics

Threads
1,118,134
Messages
5,570,349
Members
412,320
Latest member
sixnine0312
Top