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

我有一个工作表，有很多列，也很多行。 从这个工作表中，我想复制匹配2个条件的行：1.列B中的值必须与不同工作表中的下拉列表中的选定值匹配2.列F中的值必须与来自不同工作表中的选定值匹配下拉列表。

我有一个脚本，适用于条件之一。

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 

但是我不能创build符合条件2所需的脚本。

以下是文档结构的截图：

第一个条件是匹配B列中的值。这是一个可以很容易复制的封闭范围。 但第二个条件使用列F中的值，每行都在变化。

例如，基于屏幕截图，我想要select所有在列B中具有NL Food的行和列F中的Omzet（x 1000）（因此在verpakkingen中具有Verkopen（x1000）的行）必须是从select中排除。

（对于omzet（x 1.000）或Verpakking（x 1.000）的select也是使用下拉列表进行的）。

如何让VBA只select满足两个条件的行？

编辑：

我能够改变数据布局，以便现在FCT在MKT之后直接在B列。 这样，所有数据首先在MKT上sorting，然后在FCT上sorting，所以我的数据布局应该更容易select符合两个条件的区域，因为它是一个封闭的范围。

因此，我认为我能够改变代码，并满足两个条件。

我添加了一个frow2和lrow2 ，现在必须在列B中findvalue2参数。但是，在下面发布的代码中，我收到一条Error 13消息，指出“types不匹配”。 我不明白这是为什么。 我想这与我为frow2和lrow2定义search范围的方式有关。

部分调整后的代码如下，我加了斜体

 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")_ 

编辑2：

我试过这一行（见下文），找出为什么我得到错误13。

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

我在哪里使用整个列B作为search范围。 这适用于查找方法。 只要我将范围更改为其他任何内容，就会收到错误13消息：types不匹配。

看来range.find方法不能使用定义更多的整个列的范围吗？ （例如B2：B41）。

编辑3：我得到错误13消息的原因是，我在范围内search例如B2：B41和查找。 参数我inputB1作为find.after范围。 我现在改变它，它的工作原理：

 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

好吧，我会以另一种方式去。 你可以使用ADO SQL连接来获得你想要的。 我假设您的源表是schaduwlab ，我将查询结果复制到名为Sheet1的工作表。 你可以根据自己的工作来改变它们。

 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 

要获得结果，您应该在vba页面中包含Tools/References中的ADO和SQL库。 我无法检查，因为有些工作要做。 但是我从之前使用的另一个vba中安排了它。

编辑：我曾尝试过，它的工作。 在查询中也改变了引号。