Copying over whole rows when criteria over 2 columns is true

[kesh321]

Hello,

I've got a problem which I've tried solving with VBA, but have no idea how to tackle it.
Basically, I've got date column, value column and identificator column.

I need to find matches for 3 criteria:
2 dates i enter into specific cells (from - to) and identificators, which are constant strings (like OVP1, UNP1 - but doesnt matter because if there's no identificator in that row , i do not need it)

I would like to copy over whole rows with matching values to the other tab, each row in the last empty cell.
Data looks something like this:

tab "ALL"

date	value	ID
01/01/2018	VALUE1	OVP1
02/01/2018	VALUE2
02/01/2018	VALUE3	UNP1
03/01/2018	VALUE4
05/01/2018	VALUE5	ADM1

<tbody>
</tbody>

So based on dates in cell A1 (from) and B1 (to), this would copy into the other tab, only rows with VALUE1, VALUE3

The other tab "VBA" would look like this after code execution:
A1= 01/01/2018 , B1= 03/01/2018

date	value	ID
01/01/2018	VALUE1	OVP1
02/01/2018	VALUE3	UNP1

<tbody>
</tbody>

So only 2 rows with values matching would be copied over to "VBA" from "ALL" sheet. This depends on dates I input in A1, B1 sheet "VBA".

Im sure there has to be a loop and something like index/match?

Never done something like this in VBA before, any ideas how to handle this problem??

Thanks,
Matt.

 

[JackDanIce]

Hi Matt,

Try recording a macro with following steps, then post the resulting code back:

(after you've entered your date range into A1 and B1)
- Filter the date column for your date ranges
- Filter Value column for no blanks
- Select the visible rows under the header
- Press F5, then select visible cells only
- Copy and paste into VBA tab

This will generate some code if you've recorded the steps correctly. Post that code and anyone reading can suggest how to clean it or make it specific to run anytime required.

 

[kesh321]

Hiya,

Thanks for Your reply.

I've done it, but I had to skip step with pressing F5 because I was not sure what to do in there :/

This is the code I've got:

Sub Macro3()'
' Macro3 Macro
'
' Keyboard Shortcut: Ctrl+u
'
    Sheets("ALL").Select
    ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=3, Operator:= _
        xlFilterValues, Criteria2:=Array(2, "6/1/2018", 2, "6/4/2018", 2, "6/5/2018", 2, _
        "6/6/2018")
    ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=17, Criteria1:= _
        "<>"
    Range("A973:Q1015").Select
    Selection.Copy
    Sheets("vba").Select
    Range("D2").Select
    ActiveSheet.Paste
End Sub

 

[Fluff]

How about

Sub Fltrcopy()
   Dim Ws As Worksheet
   Set Ws = Sheets("Sheet1")
   With Sheets("All").ListObjects("Table1").Range
      .AutoFilter 3, ">=" & Ws.Range("a1"), xlAnd, "<=" & Ws.Range("B1")
      .AutoFilter 17, "<>"
      .SpecialCells(xlVisible).Copy Ws.Range("D2")
   End With
End Sub

 

[kesh321]

Thanks Fluff! You are the man!

I've took Your code and modified it for my needs.

One more thing, would You be able to create msgbox if no values found for filters selected ?
Here's the code:

Sub Fltrcopy()   Dim Ws1, Ws2 As Worksheet
   Application.ScreenUpdating = False
   Set Ws1 = Sheets("ALL")
   Set Ws2 = Sheets("VBA")
   With Sheets("ALL").ListObjects("Table1").Range
      .AutoFilter 3, ">=" & Ws2.Range("a2"), xlAnd, "<=" & Ws2.Range("B2")
      .AutoFilter 22, "<>"
      .SpecialCells(xlVisible).Offset(1, 0).Copy Ws2.Range("D2")
          On Error Resume Next
    ActiveSheet.ShowAllData
   End With
   Ws2.Rows("1:1000").RowHeight = 15
       On Error Resume Next
    ActiveSheet.ShowAllData
    Application.ScreenUpdating = True
End Sub

 

[Fluff]

Try

Sub Fltrcopy()
Dim Ws1 As Worksheet, Ws2 As Worksheet
   Application.ScreenUpdating = False
   Set Ws1 = Sheets("ALL")
   Set Ws2 = Sheets("VBA")
   With Ws1.ListObjects("Table1").Range
      .AutoFilter 3, ">=" & Ws2.Range("a2"), xlAnd, "<=" & Ws2.Range("B2")
      .AutoFilter 22, "<>"
      On Error GoTo NoBlanks
      .SpecialCells(xlVisible).Offset(1, 0).Copy Ws2.Range("D2")
      On Error GoTo 0
    Ws1.ShowAllData
   End With
   Ws2.Rows("1:1000").RowHeight = 15

NoBlanks:
   MsgBox "Nothing found"
   Resume Next
End Sub

 

[kesh321]

Thanks for that Fluff, looks way better

That's it from me for now, thank's for all Your help.

Please consider this solved

 

[Fluff]

Glad we could help & thanks for the feedback

 

[kesh321]

Hey,

Sorry to dig this up again, but I've just come to proper using this script in fully in the spreadsheet, and it looks like filter on the Dates (column 3) is messed up.

I've erased line to clear filters to see whats going on.

Apparently, filters for the dates choosen in between those I input myself, eg. 01/06/2018 to 06/06/2018 :
It comes out as 06/01/2018 to 06/06/2018

Simply doesnt give me the data I wish :/

Could someone take a loot into it ?

Thanks,
Matt.

 

[Fluff]

Try

      .AutoFilter 3, ">=" & CLng(Ws2.Range("A2").Value), xlAnd, "<=" & CLng(Ws2.Range("B2").Value)