列Fの特定の値を持つ範囲の行をコピーします

Question

私は多くの列とロットの行を持つワークシートを持っています。このワークシートから2つの条件に一致する行をコピーしたい： 1.列Bの値が、別のワークシートのドロップダウンリストの選択した値と一致する必要があります。 2.列Fの値が、別のドロップダウンリスト。

私は条件1のために働くスクリプトを持っています。

最初の条件が一致していることである：

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列の値で置き換えます。これは簡単にコピーできる閉じた範囲です。 しかし、2番目の条件は、すべての行を変更している列Fの値を使用します。

たとえば、スクリーンショットに基づいて、列Bの値NL Foodと列FのOmzet（x 1000）を持つすべての行を選択したいとします。したがって、verkopenen（x1000） ）を選択から除外する必要があります。

（omzet（x 1.000）またはVerpakking（x 1.000）の選択もドロップダウンリストを使用して行います）。

両方の条件を満たす行のみを選択するようにVBAを設定するにはどうすればよいですか？

編集：

私は今、FCTは直接MKT後、列Bにあるように、データのレイアウトを変更することができました。このようにして、すべてのデータはまずMKTでソートされ、その後はFCTでソートされるので、データレイアウトによって、両方の条件に一致する領域を1つの閉じた範囲として選択することが容易になります。

したがって、コードを変更して両方の条件を満たしていると思っていました。

私は今、ただし、以下掲載されているコードで、私は型が一致しません」というエラー13メッセージを取得する列Bに値2パラメータを見つける必要がありfrow2とlrow2を追加しました"私はそれがなぜあるのか分からない。私はfrow2とlrow2の検索範囲を定義した方法と関係があると思います。調整されたコードの

パートIはイタリックラインを

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

加え、以下である：私はこの線（下記参照）私はエラーを取得する理由を見つけるための試み

を

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

ここでは、検索範囲として列B全体を使用します。これはfindメソッドでうまく動作します。 範囲を他のものに変更するとすぐにエラーメッセージが表示されます：種類が一致しません。

range.findメソッドは、列全体よりも定義された範囲では機能しません。 （例えばB2：B41）。

編集3：エラー13のメッセージが表示されたのは、例B2：B41の範囲と検索で範囲が検索されたためです。パラメータfind.afterの範囲としてB1を入力しました。私はこれを今のように変更して動作させます：

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 

結果を得るには、Tools/ReferencesのADOライブラリとSQLライブラリをvbaページに含める必要があります。私はいくつかの仕事のために確認できませんでした。しかし私は前に使った別のvbaからそれを手配しました。

編集：私は試して、それは働いた。クエリの引用符も変更されました。