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

Question

我有一个包含很多列和很多行的工作表。从此工作表中，我想复制符合 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

但我无法创建同时匹配条件 2 所需的脚本。

这是文档结构的屏幕截图：
_{（来源：imgsafe.org）}

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

例如，根据屏幕截图，我想选择所有在 B 列中具有值 NL Food 的行和在 F 列中具有 Omzet (x 1000) 的行。（因此在 verpakkingen 中具有 Verkopen (x1000) 的行）必须从选择中排除。

（也可以使用下拉列表选择 omzet (x 1.000) 或 Verpakking (x 1.000)）。

如何让 VBA 只选择同时满足这两个条件的行？

编辑：

我能够更改数据布局，现在 FCT 直接位于 MKT 之后的 B 列中。这样，所有数据首先在 MKT 上排序，然后在 FCT 上排序，因此我的数据布局应该更容易选择与这两个条件匹配的区域，因为它是一个封闭范围。

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

我添加了一个 frow2 和 lrow2 现在必须在 B 列中找到 value2 参数。但是，使用发布的代码下面，我收到一条错误 13 消息，提示“类型不匹配”。我不明白为什么会这样。我想这与我定义 frow2 和 lrow2 的搜索范围的方式有关。

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

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 列作为搜索范围。这适用于 find 方法。 一旦我将范围更改为其他任何内容，我就会收到错误 13 消息：类型不匹配。

range.find 方法似乎不能用于定义的范围超过整个列？ （例如 B2:B41）。

编辑 3： 我收到错误 13 消息的原因是我在一个范围内搜索，例如 B2:B41 和 find。我输入 B1 作为 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 中整理出来的。

编辑：我试过了，它奏效了。还更改了查询中的引号。