| |
▼たえりか さん：
>ありがとうございます。すごい！これが求めてたものです！
>
>何度も申し訳ないですが、もう少し教えてください。
>教えていただいたのを参考に、応用して下記コードを書いてみようと思ったのですがうまく動きません。
>Sheet1に下記のような元のデータがあるとして（A~C列やE~G列、I列は見たいデータではないので省略）
>
>D列 H列 J列
>品名 属性 値
>リンゴ 赤a 111
>リンゴ 赤b 222
>みかん 橙c 333
>リンゴ 赤d 444
>バナナ 黄e 555
>みかん 橙f 666
>リンゴ 赤g 777
>
質問：表のA,B,C列 など ↑に書いてない列はどうなっているのでしょう？
データは
>D列 H列 J列
同様、実際はあるとみなしていいでしょうか？
>Sheet2のA1に”品名”、A2セルに入力規則を設定し選択するセルにする。
OK です。
>G5セルに”属性”、H5セルに”値”
列見出しは 元データと連動したほうがいいから、あとで実例をお見せしますが
数式で参照したほうが写し間違いが生じなくていいですよ。
>G6:H6以下に取り出したデータ
>が出るようにしようと思い下記のように書いてみました。
>
>Private Sub Worksheet_Change(ByVal Target As Range)
確認：このプロシージャは [Sheet2] に書いていますよね
Sheet2 に書いていれば、 Sheet2 が Me です。
そして Me は省略できますから、 Me.Range("A1:A2") は
たんに Range("A1:A2") でいいです。
>Dim ws1 As Worksheet, ws2 As Worksheet
>
>Set ws1 = Worksheets("Sheet1")
>Set ws2 = Worksheets("Sheet2")
>
> If Target.Address(0, 0) <> ws2.Range("A2") Then Exit Sub
↑ここが第1のまちがい
Target.Address(0, 0) とは 値変化したセルの「アドレス」のことです。
ws2.Range("A2") というのは Rangeオブジェクトのことです。
双方の「型が違います」。 比較できてません。
>
> Application.EnableEvents = False
>
> ws1.Range("H2:J2").Copy ws2.Range("G5") ‘もう面倒なのでH2~J2列までまとめてコピーして貼り付けてしまいました。
まちがいです。
ws1の2行目はデータです。 ws1 の [H1:J1]を貼り付けてください。
>
> ws1.Range("D2").CurrentRegion.AdvancedFilter _
> Action:=xlFilterCopy, _
> CriteriaRange:=ws2.Range("A1:A2"), _ ‘クライテリアはSheet2のA1:A2です。
ws1.Range("D2").CurrentRegion で ws1のE,F,G列と I列にもデータが
入っていないと（少なくとも1行目に列見出しが入ってないと）
「属性」列、「値」列がCurrentRegion に含まれないことになるので
注意してください。
あとは OK のようです♪
> CopyToRange:=ws2.Range("G5:I5") ‘G5:I5以下にSheet1のH2:J2列以下のフィルタかけた値を書き出す。
>
> Application.EnableEvents = True
>
>End Sub
参考までに 「属性」「値」だけ抽出転記するSheet2のイベントコードを
つけておきます。
'以下は [Sheet2]のモジュールコードです.
Private Sub Worksheet_Change(ByVal Target As Range)
'変更のあったセル名が[A2]でなければ抜ける
If Target.Address(0, 0) <> "A2" Then Exit Sub
Dim ws1 As Worksheet
Set ws1 = Worksheets(1)
Application.EnableEvents = False
'-----Sheet2の[G5:H5]にSheet1の[H1,J1]列見出しをCopy
[G5].Formula = "=" & ws1.Name & "!H1"
[H5].Formula = "=" & ws1.Name & "!J1"
'フィルタによる「属性」「値」データの抽出転記
ws1.[A1].CurrentRegion.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=[A1:A2], _
CopyToRange:=[G5:H5]
Dim r As Range
Set r = Range("G5", Cells(Rows.Count, "G").End(xlUp)) _
.Resize(, 2)
If r.Rows.Count > 2 Then
r.Sort Key1:=r.Columns(2), Header:=xlYes
End If
Application.EnableEvents = True
End Sub
|
|
kanabun
- 13/8/2(金) 11:15 -
