在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所需的脚本。

以下是文档结构的截图：

第一个条件是与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作为搜索范围。这适用于查找方法。 只要我将范围更改为其他任何内容，我就会收到错误13消息：类型不匹配。

似乎 range.find 方法无法使用定义多于整列的范围？ （例如B2：B41）。

编辑3：我收到错误13消息的原因是我在范围内搜索了例如B2：B41和查找。参数我输入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中安排了它。

编辑：我曾尝试过并且有效。还更改了查询中的引号。