Copy paste values to another workbook based on multiple cell values

Hi All,

I have some basic understanding of VBA, but I cannot find a proper solution for the following:

I have a dataset with a lot of entries, which is still growing. In order to have a better overview of several specific items, I would like to export (copy paste values) the information of each row to another sheet when it matches multiple cell values. The cell values are the date, a category and a specification.

In the attachment I included a sample workbook.

Hope you guys can help me with this problem.

Thanks in advance!

Hi Bazinga

Try this Code in the attached. There are two Buttons, "1 Create Lists" and "2 Extract Stuff".

"1 Create Lists" needs clicked initially. It will then need be clicked any time you add Data to the Worksheet.

"2 Extract Stuff" does all of this

I would like to export (copy paste values) the information of each row to another sheet when it matches multiple cell values. The cell values are the date, a category and a specification.

Option Explicit

Sub Button3_Click()
  Dim LR As Long
  Range("K:M").ClearContents

  LR = Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByRows, _
      SearchDirection:=xlPrevious).Row
  Range("B5:B" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
      "K5"), Unique:=True
  ActiveWorkbook.Names.Add Name:="Date", RefersTo:= _
      "=OFFSET(Input!$K$6,0,0,(COUNTA(Input!$K:$K)-1),1)"
  Range("C5:C" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
      "L5"), Unique:=True
  ActiveWorkbook.Names.Add Name:="Category", RefersTo:= _
      "=OFFSET(Input!$L$6,0,0,(COUNTA(Input!$L:$L)-1),1)"
  Range("D5:D" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
      "M5"), Unique:=True
  ActiveWorkbook.Names.Add Name:="Spec", RefersTo:= _
      "=OFFSET(Input!$M$6,0,0,(COUNTA(Input!$M:$M)-1),1)"

End Sub



Sub Button5_Click()
  Dim LR As Long
  Dim wsSrc As Worksheet, wsTgt As Worksheet
  
  Set wsSrc = ActiveSheet
  Set wsTgt = Sheets("Output")
  
  Application.ScreenUpdating = False
  With wsTgt
  .Cells.ClearContents
  End With

With wsSrc
  LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
      SearchDirection:=xlPrevious).Row
  If .AutoFilterMode Then
    .Range("B5").AutoFilter
  End If
  .Range("B5:G" & LR).AutoFilter Field:=1, Criteria1:="=" & .Range("J5").Text & ""
  .Range("B5:G" & LR).AutoFilter Field:=2, Criteria1:="=" & .Range("J6").Text & ""
  .Range("B5:G" & LR).AutoFilter Field:=3, Criteria1:="=" & .Range("J7").Text & ""
  .Range(.Cells(5, 2), .Cells(LR, "G")).SpecialCells(xlCellTypeVisible).Copy
  wsTgt.Range("A1").PasteSpecial (xlPasteColumnWidths)
  wsTgt.Range("A1").PasteSpecial (xlPasteValues)
  wsTgt.Range("A1").PasteSpecial (xlPasteFormats)
  .AutoFilterMode = False
  End With
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
  wsTgt.Activate
End Sub

You're welcome...glad I could help. Thanks for the Rep.