复制F列中具有特定值的范围内的行

Question

I have an worksheet with lots of columns and also lots rows. from this worksheet I want to copy the rows which match 2 conditions: 1. the value in column B must match the selected value from a dropdown list in a different worksheet 2. the value in column F must match with the selected value from a different dropdown list.

I have a script that works for condition one.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim fRow As Integer, lRow As Integer
Dim value As String
Dim mychart As chart
Dim mycharts As ChartObject

If ActiveCell.Address = Sheets("blad1").Cells(1, 1).Address Then

Sheets("chartdata").Cells.ClearContents

For Each ChartObject In Sheets("blad3").ChartObjects
ChartObject.Delete
Next

value = Sheets("blad1").Cells(1, 1).value

With Sheets("schaduwblad")
fRow = .Range("B:B").find(what:=value, after:=Range("B1")).Row
lRow = .Range("B:B").find(what:=value, after:=Range("B1"), lookat:=xlWhole, searchdirection:=xlPrevious).Row
.Range("B1:DT1").Copy _
Sheets("chartdata").Range("A1")
.Range("B" & fRow, "DT" & lRow).Copy _
Sheets("chartdata").Range("A2")


  With Sheets("blad3")
  Set mychart = .Shapes.AddChart.chart

    With mychart
      .SetSourceData Source:=Sheets("chartdata").Range("B1").CurrentRegion
      .ChartType = xlLine
      .HasTitle = True
      .HasLegend = True

      With .ChartTitle
      .Text = "=Blad1!R1C1"
      .AutoScaleFont = False
      .Font.FontStyle = "verdana"

      End With
      With mychart.Legend

        .FontSize = 8
        .Position = xlLegendPositionBottom
        .AutoScaleFont = False
        .Font.FontStyle = "verdana"
        .FontSize = 8
      End With

    End With
  End With
End With
End If
End Sub

But I cannot create the script that is needed to also match condition 2.

Here is a screenshot from the structure the document has:
_{(source: imgsafe.org )}

The first condition is that the match with the value in column B. That is a closed range which can easily be copied. But the second condition uses the value in column F, which is changing every row.

For example, based on the screenshot, I want to select all the rows which have the value NL Food in column B and the Omzet (x 1000) in column F. (so rows which have Verkopen (x1000) in verpakkingen) have to be excluded from the selection.

(the choice for omzet (x 1.000) or Verpakking (x 1.000) is also made using a drop down list).

How can I make VBA to only select the rows which meet both conditions?

Edit:

I was able to change the data layout so that now FCT is in column B directly after MKT. This way, all data is first sorted on MKT and after that on FCT so my data layout should make it easier to select the area which matches both conditions, as it is one closed range.

Therefore, I thought I was able to change the code and have both conditions met.

I added a frow2 and lrow2 which now have to find the value2 parameter in column B. However, with the code which is posted below, I get an Error 13 message saying "types do not match". I do not understand why that is. I guess it has something to do with the way I defined the search range for frow2 and lrow2.

Part of the adjusted code is below, I added the italic lines

Private Sub Worksheet_Change(ByVal Target As Range)
Dim fRow As Integer, lRow As Integer, frow2 As Integer, lrow2 As Integer

Dim value As String
Dim value2 As String
Dim mychart As chart
Dim mycharts As ChartObject

If ActiveCell.Address = Sheets("blad1").Cells(1, 1).Address Then

Sheets("chartdata").Cells.ClearContents

For Each ChartObject In Sheets("blad3").ChartObjects
ChartObject.Delete
Next

value = Sheets("blad1").Cells(1, 1).value
value2 = Sheets("blad1").Cells(1, 3).value

With Sheets("schaduwblad")
fRow = .Range("A:A").find(what:=value, after:=Range("A1")).Row
lRow = .Range("A:A").find(what:=value, after:=Range("A1"), lookat:=xlWhole, searchdirection:=xlPrevious).Row
frow2 = .Range(.Cells(fRow, 2), .Cells(lRow, 2)).find(what:=value2, after:=Range("B1"), lookat:=xlWhole).Row
lrow2 = .Range(.Cells(fRow, 2), .Cells(lRow, 2)).find(what:=value2, after:=Range("B1"), lookat:=xlWhole, searchdirection:=xlPrevious).Row
.Range("E1:DS1").Copy
Sheets("chartdata").Range("A1")
.Range("E" & fRow, "DS" & lrow2).Copy_
Sheets("chartdata").Range("A2")_

EDIT 2:

I tried this line (see below) to find out why I get the error 13.

frow2 = .Range("B:B").find(what:=value2, after:=Range("B1"), lookat:=xlWhole).Row

Where I use the entire column B as search range. This works fine for the find methode. As soon as I change the range to anything else I get the error 13 message: types do not match.

It seems the range.find method cannot work with ranges which are defined more then just an entire column? (eg B2:B41).

Edit 3: The reason I got the error 13 message was that I searched in a range for example B2:B41 and in the find. parameters I entered B1 as find.after range. I changed it now like this and it works:

frow2 = .Range(.Cells(fRow, 2), .Cells(lRow, 2)).find(what:=value2, after:=Range("B" & fRow), lookat:=xlWhole).Row
lrow2 = .Range(.Cells(fRow, 2), .Cells(lRow, 2)).find(what:=value2, after:=Range("B" & fRow), lookat:=xlWhole, searchdirection:=xlPrevious).Row

Answer 1

Ok, I ll go with another way. You can use ADO SQL connection to get what you want. I have assumed your source sheet is schaduwlab and I copied query results to a sheet named Sheet1 . You can change them according to your own work.

Sub tadaaa()

Dim con As Object, rs As Object
Dim query As String
Dim connector As String
Dim adres As String


    Set con = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")

    adres = ThisWorkbook.FullName

    connector = "provider=microsoft.ace.oledb.12.0;data source=" & _
             adres & ";extended properties=""Excel 12.0 Macro;hdr=yes"""

    con.Open connector


    query = "select * from [schaduwblad$] where FCT = ""Omzet (x 1000)"" AND MKT = ""NL Food"""
                            'Source sheet


    Set rs = con.Execute(query) 'Execute the query

    'Recording query results to any sheet you want.
    Sheets("Sheet1").Range("A65536").End(3).Offset(1, 0).CopyFromRecordset rs

    For j = 0 To rs.Fields.Count - 1 'For the headers
        Sheets("Sheet1").Cells(1, j + 1).Value = rs.Fields(j).Name
    Next j


Set rs = Nothing

Set con = Nothing


End Sub

To get results, you should include ADO and SQL libraries from Tools/References in vba page. I couldn't check because of some works to do. But I arranged it from another vba that I have used before.

Edit: I had tried and it worked. Also changed quotes in query.