VBA copy entire row based on multiple criteria

[GEO81]

Hello!

I'm working on a macro and i need some help.
I need to copy the entire rows from another workbook to my active workbook if a condition is met. The condition is a combination or 3 other conditions conected with OR.

I'm giving an example below.
Lets say i have the below table and my condition is: If Value1 is =<30 OR Value2=<100 or Value3 =<50 THEN copy the entire row to my active workbook/worksheet.
Just to mention that i need the Input Values 30, 100, 50 to have flexibility to amend. So I need an Input Box to prompt the user to enter those 3 conditions.
So should i use a UserForm?

Also i have to ensure that Blank cells will not be considered as cells with Value=0.

Data1	Data2	Data3	Value1	Value2	Value3
Name1	A	1​	20​	150​
Name2	B	2​	10​	200​	10​
Name3	C	3​		100​	15​
Name4	D	4​	100​		50​
Name5	E	5​	80​	0​	60​
Name6	F	6​	35​
Name7	G	7​			40​
Name8	H	8​		120​
Name9	I	8​			80​

The Result should be the following Table:

Data1	Data2	Data3	Value1	Value2	Value3
Name1	A	1​	20​	150​
Name2	B	2​	10​	200​	10​
Name3	C	3​		100​	15​
Name4	D	4​	100​		50​
Name5	E	5​	80​	0​	60​
Name7	G	7​			40​

Any help is more than welcome!
Thanks!

 

[Marc L]

Hello,​

​

or just using some cells as criterion to be combined with an easy advanced filter …​

​

 

[GEO81]

Hello,​

​

or just using some cells as criterion to be combined with an easy advanced filter …​

​

Actually my vba is more complicated and i'm retreiving data from many excel workbooks and worksheets. So i'm not sure how the advanced filter will work.

 

[GEO81]

Hello,​

​

or just using some cells as criterion to be combined with an easy advanced filter …​

​

Hi,

I figure out something but i saw that the advanced filter requires the headers to be all the same. in my case, the Columns at the different excel sheets have the same values but the headers may differ on the description.
So the command "CopyToRange:=Sheets("sheet2").Range("I10:N10")" will not work.
How can i copy the entire row? Any suggestion please?

Below is my example

Sub AdvancedFilterCopyDemo()

Range("A:F").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("J3:L6"), _
CopyToRange:=Sheets("sheet2").Range("I10:N10")
End Sub

 

[Marc L]

Can't work without same headers …​

 

[GEO81]

​

Can't work without same headers …​

so any other suggestion how i can achive what i want?
Maybe a UserForm?

 

[Marc L]

Use a filter whatever according to some cells or an userform then copy the data …​

 

[Marc L]

​

You can also use an advanced filter to filter in place then use the Range.Copy method to copy the data …​

 

[Peter_SSs]

the Columns at the different excel sheets have the same values but the headers may differ on the description.

That shouldn't matter provided the original data is to be copied in the same column order.
You should still be able to do an xlFilterCopy

Assuming ..

• The first table shown in post #1 is on Sheet1, starting in cell A1
• There is nothing to the right of this table (code can be adapted if there is)
• The 'different' headers on Sheet2 are in I10:N10
• There is nothing below those headers in Sheet2

.. then give this a try with a copy of your workbook.

Sub FilterAndCopy()
  Dim aVals As Variant
  Dim InputVals As String
  Dim rCrit As Range
  
  InputVals = InputBox("Enter upper limits for Val 1, Val 2, and Val 3, separated by spaces. eg 30 100 50")
  aVals = Split(InputVals)
  If UBound(aVals) = 2 Then
    With Sheets("Sheet1").Range("A1").CurrentRegion
      Set rCrit = .Cells(1, .Rows.Count + 2).Resize(2)
      rCrit.Cells(2).Formula = "=OR(AND(D2<=" & aVals(0) & ",D2<>""""),AND(E2<=" & aVals(1) & ",E2<>""""),AND(F2<=" & aVals(2) & ",F2<>""""))"
      .AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rCrit, CopyToRange:=Sheets("Sheet2").Range("I11"), Unique:=False
      rCrit.ClearContents
    End With
    Sheets("Sheet2").Range("I11:N11").Delete Shift:=xlUp
  End If
End Sub

 

[GEO81]

That shouldn't matter provided the original data is to be copied in the same column order.
You should still be able to do an xlFilterCopy

Assuming ..

• The first table shown in post #1 is on Sheet1, starting in cell A1
• There is nothing to the right of this table (code can be adapted if there is)
• The 'different' headers on Sheet2 are in I10:N10
• There is nothing below those headers in Sheet2

.. then give this a try with a copy of your workbook.

Sub FilterAndCopy()
  Dim aVals As Variant
  Dim InputVals As String
  Dim rCrit As Range
 
  InputVals = InputBox("Enter upper limits for Val 1, Val 2, and Val 3, separated by spaces. eg 30 100 50")
  aVals = Split(InputVals)
  If UBound(aVals) = 2 Then
    With Sheets("Sheet1").Range("A1").CurrentRegion
      Set rCrit = .Cells(1, .Rows.Count + 2).Resize(2)
      rCrit.Cells(2).Formula = "=OR(AND(D2<=" & aVals(0) & ",D2<>""""),AND(E2<=" & aVals(1) & ",E2<>""""),AND(F2<=" & aVals(2) & ",F2<>""""))"
      .AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rCrit, CopyToRange:=Sheets("Sheet2").Range("I11"), Unique:=False
      rCrit.ClearContents
    End With
    Sheets("Sheet2").Range("I11:N11").Delete Shift:=xlUp
  End If
End Sub

HI Peter! Thank you for your suggestion and sorry for the late reply.
I got sick and then busy with other priorities!
I have applied the logic you mentioned and worked for simple tables.
Unfortunately some of my excel files have merged data so I need to work a lit bit to make them listed properly.
Thank you again!