[[20071101102827]]　『マクロでオートフィルタ後のセルをコピー→数値の』（としまる）　ページの最後に飛ぶ

『マクロでオートフィルタ後のセルをコピー→数値のみ貼付→セル１つ下げる』（としまる）

 内容
 いつも、大変お世話になります。
 標題に関し、マクロで種類欄をオートフィルタで絞り込んだ場合、定量的ではない製品群
 （例えばA製品は3つあったりB製品は4つあったりE製品は2つしかなったり・・・）
 に対し計算結果を値のみ貼付し、セルを一つ下げることは可能なのでしょうか？
 定量的な製品群であれば、用意であると思われますが・・・
 そこで、詳細な内容を以下に書き込みましたので御教授よろしくおねがいいたします。

 １．まずこのようなデータがあります。
 ２．計算結果を値のみ貼り付けしていくのが最終的な目標です

　　　　　A列　　　B列　　　C列　　　D列　　　E列

 1	製品名	種類	数値1	数値2	計算結果
 2	A製品	1	50	50	=C2+D2
 3	A製品	2	50	50	=C3+D3
 4	A製品	3	50	50	=C4+D4
 5	B製品	1	50	50	=C5+D5
 6	B製品	2	50	50	=C6+D6
 7	B製品	3	50	50	=C7+D7
 8	B製品	4	50	50	=C8+D8
 9	C製品	1	50	50	=C9+D9
 10	C製品	2	50	50	=C10+D10
 11	C製品	3	50	50	=C11+D11
 12	D製品	1	50	50	=C12+D12
 13	D製品	2	50	50	=C13+D13
 14	D製品	3	50	50	=C14+D14
 15	D製品	4	50	50	=C15+D15
 16	E製品	1	50	50	=C16+D16
 17	E製品	2	50	50	=C17+D17

 ３作業手順
 事前にオートフィルタで種類１や２を絞り込む

 種類１をオートフィルタで絞り込む場合
 　　　　　A列　　　B列　　　C列　　　D列　　　E列
 1	製品名	種類	数値1	数値2	計算結果
 2	A製品	1	50	50	=C2+D2
 5	B製品	1	50	50	=C5+D5
 9	C製品	1	50	50	=C9+D9
 12	D製品	1	50	50	=C12+D12
 16	E製品	1	50	50	=C16+D16

 ４作業者がE2をアクティブにします
 （このセルを計算結果のみ貼りつけいきたい→E列を下に全部）
 マクロ実行１・・・コピー
 マクロ実行２・・・数値のみ貼りつけ
 マクロ実行３・・・E5へ移動
 マクロ実行４・・・エスケープ
 マクロ実行５・・・画面1行したにスクロール
 END

 ５＊もう一度実行するとE9へセルが移動し、実行度E12、E16と移動していくのがポイントです。
 （つまり製品群が定量的ではないために、定量的なセルの移動が出来ない
 →オートフィルタ後の定量姓のないセルの移動はどうしたらいいのか？）

 ６結果
 1	製品名	種類	数値1	数値2	計算結果
 2	A製品	1	50	50	100
 5	B製品	1	50	50	100
 9	C製品	1	50	50	100
 12	D製品	1	50	50	100
 16	E製品	1	50	50	100

 E列は種類2-4を変更せず、値のみ貼りつけることが出来ました。

 以上よろしくおねがいいたします

 質問内容が非常にわかりにくいです。
定量的という言葉がそれを助長しています。
おそらく、製品名の数が一定でないということを仰りたいとは思いますが、通常そのようなことに定量という言葉は使わないと思います。
（何個あるかは数えられるのだから、定量できますよね？5個以上あるかないかを調べる→これは定性になりますね？）
　
さて、上記仮定のもと、質問を再度確認いたします。
　
製品名で最初に出てくるものに対して、計算結果（数値１と数値２の加算）を値貼り付けしたい
ということでよろしいでしょうか？
(ROUGE)

 失礼致しました。
 定量的は製品名の数が一定でないということという意味で理解願います。
 製品名で最初に出てくるものに対して、
 計算結果（数値１と数値２の加算）を値貼り付けしたいということでよろしいでしょうか？、という意味は
 →オートフィルタ後の製品名の計算結果（数値１と数値２の加算）を数値のみ貼りつけたいということです。

 ご検討よろしくおねがいいたします。

 オートフィルタは手動でされるということでよろしいですか？

 With Intersect(Range("E:E"),Range("E1").CurrentRegion).SpecialCells(xlVisible)
   .Value = .Value
 End With

 (ROUGE)

　 (ROUGE)さんへ

 オートフィルタは手動でします。

  With Intersect(Range("E:E"),Range("E1").CurrentRegion).SpecialCells(xlVisible)
    .Value = .Value
  End With

 ↑E2で実行してみましたがこのような結果になりました。
 製品名	種類	数値1	数値2	計算結果		
 A製品	1	50	50	100		
 B製品	1	50	50	計算結果		
 C製品	1	50	50	計算結果		
 D製品	1	50	50	計算結果		
 E製品	1	50	50	計算結果

 補足
 種類２～４で絞り込んだ場合も同様に値のみのコピーをしていきたいと思っています。

 検証していませんでした。申し訳ございません。
 それではFor Eachループで処理する例です。
 (ROUGE)
'----
Dim rng As Range
For Each rng In Intersect(Range("E2", Cells(Rows.Count, 5)), _
    Range("E1").CurrentRegion).SpecialCells(xlVisible)
    rng.Value = rng.Value
Next

 (ROUGE)さんへ
 上記マクロ確認いたしました。
 上記マクロは実行すると一度に全ての表示されているE列の値が値のみになりますが、
 そうではなく
 作業者がE2を指定したらマクロ実行後、一つしたのE5に移動、
 そしたら作業者がまた、マクロ実行後E5を値のみコピーしてE9に移動、
 そしたら作業者がまた、マクロ実行後E9を値のみコピーしてE12に移動、
 そしたら作業者がまた、マクロ実行後E12を値のみコピーしてE16に移動、
 というように、作業者が一回ずつ実行するので一気に値化する必要はないのです。

 また、こんな場合もあります
 作業者が、E2ではなく、いきないりE９を指定する場合もあり、この場合はマクロ実行後、
 E12へ下がります。
 つまり、値化するセルはどの行をするかは作業者に任せたいということと、
 一つのセルのみ値化し下がっていることが今回のマクロのポイントです

 あっつ！そうそう！だからE列にこだわる必要もないのです。
 重要なことはオートフィルタで絞られている行に対し、マクロを実行したらそのセルが値化され、
 1行下がり、画面を一つスクロールできていれば良いのです

 ご検討よろしくおねがいいたします。

 スクロールは本当に必要ですか？(ROUGE)
'----
Sub test1()
Dim rng As Range, adrs As String, flg As Boolean
flg = False
adrs = ActiveCell.Address
For Each rng In Intersect(Range("E2", Cells(Rows.Count, 5)), _
    Range("E1").CurrentRegion).SpecialCells(xlVisible)
    If flg Then
        rng.Select
        ActiveWindow.SmallScroll Down:=1
        Exit For
    End If
    If rng.Address = adrs Then
        rng.Value = rng.Value
        flg = True
    End If
Next
End Sub

 (ROUGE)さん、動作確認いたしました。
 本来データは何千行あるのでスクロールは必要でOKです。（列も本来もっとあります）

 ただ、最後に今回、私はE列限定で話を進めていましたが、
 作業者が任意にオートフィルタ後の列と行を指定してあげさせたいため、
 A列B列C列D列F列G列H列I列J列K列L列・・・、
 どこでも実行できるように変更していただけないでしょうか。よろしくおねがいいたします

 これでどうでしょうか。(ROUGE)
'----
Sub test1()
Dim rng As Range, adrs As Range, flg As Boolean
flg = False
Set adrs = ActiveCell
For Each rng In Intersect(Range(Cells(2, adrs.Column), Cells(Rows.Count, adrs.Column)), _
    Range("A1").CurrentRegion).SpecialCells(xlVisible)
    If flg Then
        rng.Select
        ActiveWindow.SmallScroll Down:=1
        Exit For
    End If
    If rng.Address = adrs.Address Then
        rng.Value = rng.Value
        flg = True
    End If
Next
End Sub

 (ROUGE)さん
 出来ました。
 ありがとうございます
 また、機会がありましたら、次回もよろしくおねがいいたします。

コメント返信：

[ 一覧(最新更新順) ]

[[20071101102827]] 『マクロでオートフィルタ後のセルをコピー→数値の』（としまる） ページの最後に飛ぶ

[[20071101102827]]　『マクロでオートフィルタ後のセルをコピー→数値の』（としまる）　ページの最後に飛ぶ