[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBA フィルター抽出 別シートの数字一致する行の上に挿入』（ぶん）
作業用ｼｰﾄＡ列に8ｹﾀの数字（昇順で表示・重複あり）、Ｄ列に1〜60までの数字、
Ｆ列に1〜3000の数字が入力されています。
Ｆ列の550以下のものをフィルター抽出し、ws4のシートにコピーしています。
次に以下動作を実行したいのですが分かりません。
Ｄ列に46以上のものがある場合（ない時もあります）にフィルターで抽出し同じくws4にコピーしたいです。
ただし貼り付け先が、先に抽出したデータのＡ列で重複する数字の行の一番上に行挿入で貼り付けたいです。
また46以上のものがＡ列で重複しない場合もあります・・・
その場合はＡ列の昇順通りの位置に行挿入したいです。
Ａ列の重複している数字の行位置はバラバラではなく必ず続いています。
Sub 正方形長方形1_Click()
Dim ws1, ws2, ws3, ws4 As Worksheet
Dim lastrow1, lastrow2, lastrow3 As Long
Set ws2 = Sheets("作業シート")
Set ws3 = Sheets("data")
Set ws4 = Sheets("ツイン")
ws4.Select 'ツインのシート選択
ws4.Range(Cells(2, 1), Cells.SpecialCells(xlLastCell)).Delete '前日分削除
ws3.Copy after:=Worksheets(1) '作業用ｼｰﾄ作成
Set ws1 = ActiveSheet
With ws1
.Range("A:B,M:N,S:T,W:Y").Delete shift:=xlToLeft '不要行削除
If .AutoFilterMode Then .AutoFilter.Range.AutoFilter 'フィルター確認
With Range("A1").CurrentRegion
Range("A1", .Cells(.Count)).AutoFilter 'フィルターモード
.Range("A1").AutoFilter Field:=6, Criteria1:="<=550", _
Operator:=xlAnd '長さ550以下
lastrow1 = Range("A" & Rows.Count).End(xlUp).Row '最終行取得
Range(Cells(2, 1), Cells(lastrow1, 16)).Copy ws4.Range("B2") 'ツインシートに貼り付け
End With
If ws1.FilterMode Then ws1.ShowAllData
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
Sheets("data") のフォーマットと云うか(私の推測）
読込加工する情報が解らないので
再現のしようがない様に思うのですが。
コードも途中で切れており全体が解りづらいです。
＞＞作業用ｼｰﾄＡ列に8ｹﾀの数字（昇順で表示・重複あり）、Ｄ列に1〜60までの数字、
＞＞ Ｆ列に1〜3000の数字が入力されています。
が Set ws2 = Sheets("作業シート") ならば
何処に反映されるのでしょうか。
レンジオブジェクトが何処のシートのものか解らないものがあり
誤読、誤動作の原因になりますので、明示された方が良いかと。
フイルター後の結果のフォーマットも
具体的にどうなるのかご提示いただけると。。。
私では無理かもしれませんが
他の方から、多数回答が有るかもしれません。
以上、気が付いた点だけで済みません。。。
（隠居じーさん） 2018/09/05(水) 17:35
（隠居じーさん） 2018/09/05(水) 18:06
D列でフィルタした結果のA列のVisibleCellをループ・コピーして、ws4マッチする該当行に挿入 という手順になりませんか？ （seiya） 2018/09/05(水) 18:33
iPhoneからなんでなんとなくですけど、 取り敢えず貼り付け先の下に貼り付けておいて 並び替えるのが手っ取り早い様に思います で、後から挿入した分がわかる様に 印をつけておいてその列でもその印が 上に来る様に並び替えればいい様な？ どうでしょう？ （SoulMan） 2018/09/05(水) 20:46
Sub 正方形長方形1_Click()
Dim dstRNG As Range
With Sheets("ツイン")
Intersect(UsedRange, UsedRange.Offset(1)).Delete '1行目以外を削除
Set dstRNG = .Range("B2")
End With
'dataを２シート目にコピー挿入して作業シートを生成
Sheets("data").Copy after:=Worksheets(1)
'２シート目にコピー挿入した「作業用シート」の操作
With Worksheets(2)
'オートフィルタ強制解除
.AutoFilterMode = False
'不要【列】削除
.Range("A:B,M:N,S:T,W:Y").Delete shift:=xlToLeft
'A1セルを含む表範囲にオートフィルタを設定し、F列が 長さ550以下 のものを抽出
.Range("A1").AutoFilter Field:=6, Criteria1:="<=550", Operator:=xlAnd
'抽出したもの（項目行を含む）を「ツイン」シートのB2に貼付
.Range("A1").CurrentRegion.Copy dstRNG
'抽出状態の解除？ "作業シートなのでシートごと削除される運命にありそうだけど・・"
.ShowAllData
End With
'余分にコピーした項目行の削除
Sheets("ツイン").Rows(2).Delete
End Sub
こういうことではなかろうかとおもいます。
これでよいのであれば、「ツイン」の続きの行に貼付したいってことでしょうから、ツインシートの最終行を調べたうえで、dstRNGにシートの（最終行+1、B列）のセルをセットしてあげて、もういちど
抽出 ＆ dstRNGへコピペ
となるように組めばよさそうな気がしますがどうでしょうか。
※ツインシートの１行目には項目行などで使っていて、UsedRangeの１行目は、シートの１行目と一致することが前提です。
（もこな２） 2018/09/06(木) 02:05
ただ、
ws4.Range(Cells(2, 1), Cells.SpecialCells(xlLastCell)).Delete
なので、もともとAに何か数式などがあったとしても、さっくり削除されていますし、
〜.Copy ws4.Range("B2")
なので、提示されたコードだと、A列はブランクになってしまうのでは？
具体的なデータ例なんぞの提示があれば、皆さん解釈して回答してくださるような気がします。
（もこな２） 2018/09/06(木) 02:16
Dim ws1, ws2, ws3, ws4 As Worksheet Dim lastrow1, lastrow2, lastrow3 As Long
↑だと、ws4、lastrow3 以外は全部Variant型で宣言してることになってるから、意図していないなら直したほうがいいかもです。
1、２度しか出てこないものを、いちいち変数に入れる必要があるのかということは別途考えたほうがよいとは思いますが・・・・
（もこな２） 2018/09/06(木) 02:22
恐怖の憶測推測dataシート情報 ＾＾
A B C D E F G H I J K L M N O P Q R S T U V W X Y
1 科目 項目B1 項目C1 項目D1 項目E1 項目F1 項目G1 項目H1 項目I1 項目J1 項目K1 項目L1 項目M1 項目N1 項目O1 項目P1 項目O2 項目P2 項目O3 項目P3 項目O4 項目P4 項目O5 項目P5 項目O6
2 科目7 どうせかっと 11112222 ぶり 材質7 75 5,000 2,598 97,283 890,741 244,985 615,767 703,842 662,127 497,427 703,592 190,918 441,221 968,516 688,982 930,176 867,630 16,894 56,985 969,131
3 科目8 どうせかっと 11112222 ぶり 材質8 59 5,000 143 437,642 128,141 247,607 397,329 127,409 593,693 264,104 474,413 435,840 445,999 550,621 961,545 813,645 22,586 734,857 540,078 381,915
4 科目17 どうせかっと 11112222 ぶり 材質17 37 4,000 777 14,933 887,981 875,219 357,841 529,176 962,941 92,383 663,863 116,219 796,427 492,710 33,435 917,436 674,951 711,209 34,505 260,874
5 科目1 どうせかっと 12345678 てんぷら 材質1 63 9,000 387 700,197 666,886 920,428 303,534 966,708 251,743 294,755 405,345 414,478 630,330 243,655 371,695 448,391 814,101 735,023 525,860 966,633
6 科目2 どうせかっと 12345678 てんぷら 材質2 42 7,000 32 820,401 124,495 763,153 846,922 583,962 806,927 144,828 66,468 143,908 442,937 722,979 532,507 684,715 224,397 321,959 49,887 357,114
7 科目10 どうせかっと 12345678 てんぷら 材質10 20 1,000 2,935 524,264 507,515 299,291 382,643 210,520 391,710 855,008 28,135 264,489 497,822 312,012 762,101 362,319 47,723 689,605 580,087 651,079
8 科目11 どうせかっと 12345678 てんぷら 材質11 80 6,000 1,119 28,638 831,781 873,441 104,912 305,639 553,920 961,292 819,320 84,606 508,173 261,356 740,556 934,522 415,068 224,723 650,643 317,199
9 科目3 どうせかっと 12345680 すきやき 材質3 76 5,000 2,845 728,903 897,256 25,363 791,487 527,666 998,329 435,501 297,686 107,474 310,083 699,614 258,172 432,787 575,542 929,185 683,930 133,965
10 科目4 どうせかっと 12345680 すきやき 材質4 36 6,000 969 854,088 872,689 192,527 250,989 79,745 570,661 669,771 78,927 382,586 391,509 652,039 590,267 278,232 673,871 74,395 336,610 278,160
11 科目5 どうせかっと 12345680 すきやき 材質5 58 1,000 736 119,136 796,993 655,137 121,562 402,865 439,253 870,825 682,044 993,575 565,419 892,181 680,773 821,495 703,136 246,246 589,371 375,503
12 科目12 どうせかっと 12345680 すきやき 材質12 55 5,000 1,884 868,708 357,905 925,640 293,951 22,179 50,792 911,560 718,689 724,509 61,001 805,872 338,835 377,145 988,830 969,905 290,841 255,885
13 科目13 どうせかっと 12345680 すきやき 材質13 39 3,000 2,779 86,899 246,935 753,250 917,297 334,776 695,193 667,048 96,691 480,325 151,632 160,244 197,157 393,112 24,654 687,593 144,270 61,820
14 科目14 どうせかっと 12345680 すきやき 材質14 45 4,000 2,696 482,305 758,773 573,534 701,675 66,217 521,162 318,628 891,817 387,547 411,806 776,371 555,114 83,860 699,869 289,627 522,301 394,169
15 科目6 どうせかっと 12345683 いりじゃこ 材質6 54 3,000 197 315,829 844,033 104,714 336,456 900,527 910,819 766,419 820,129 884,821 203,713 214,864 46,228 187,951 736,779 201,166 929,970 276,799
16 科目15 どうせかっと 12345683 いりじゃこ 材質15 49 6,000 1,365 318,617 254,004 144,373 143,638 809,908 774,810 527,955 876,580 697,850 37,503 134,201 428,135 72,557 896,395 598,261 583,132 163,102
17 科目9 どうせかっと 33333333 さわら 材質9 35 8,000 2,816 450,600 232,244 302,728 757,170 619,198 840,358 1,184 660,207 284,346 445,322 661,222 621,729 963,104 605,616 853,712 258,779 704,350
18 科目18 どうせかっと 33333333 さわら 材質18 22 3,000 2,963 936,280 875,371 72,208 401,109 251,225 164,773 614,123 681,323 327,933 29,812 519,074 67,147 767,962 565,430 85,485 18,412 843,322
19 科目16 どうせかっと 36363633 いか 材質16 58 6,000 808 91,653 193,268 342,336 502,936 808,155 225,275 226,905 498,093 574,588 863,187 966,605 956,123 999,670 383,124 477,062 2,613 123,978
実行結果
A B C D E F G H I J K L M N O P Q
1
2 11112222 ぶり 材質8 59 5,000 143 437,642 128,141 247,607 397,329 264,104 474,413 435,840 445,999 813,645 22,586
3 11112222 ぶり 材質7 75 5,000 2,598 97,283 890,741 244,985 615,767 497,427 703,592 190,918 441,221 930,176 867,630
4 11112222 ぶり 材質8 59 5,000 143 437,642 128,141 247,607 397,329 264,104 474,413 435,840 445,999 813,645 22,586
5 12345678 てんぷら 材質11 80 6,000 1,119 28,638 831,781 873,441 104,912 961,292 819,320 84,606 508,173 934,522 415,068
6 12345678 てんぷら 材質1 63 9,000 387 700,197 666,886 920,428 303,534 294,755 405,345 414,478 630,330 448,391 814,101
7 12345678 てんぷら 材質1 63 9,000 387 700,197 666,886 920,428 303,534 294,755 405,345 414,478 630,330 448,391 814,101
8 12345678 てんぷら 材質2 42 7,000 32 820,401 124,495 763,153 846,922 144,828 66,468 143,908 442,937 684,715 224,397
9 12345680 すきやき 材質12 55 5,000 1,884 868,708 357,905 925,640 293,951 911,560 718,689 724,509 61,001 377,145 988,830
10 12345680 すきやき 材質5 58 1,000 736 119,136 796,993 655,137 121,562 870,825 682,044 993,575 565,419 821,495 703,136
11 12345680 すきやき 材質3 76 5,000 2,845 728,903 897,256 25,363 791,487 435,501 297,686 107,474 310,083 432,787 575,542
12 12345683 いりじゃこ 材質15 49 6,000 1,365 318,617 254,004 144,373 143,638 527,955 876,580 697,850 37,503 72,557 896,395
13 12345683 いりじゃこ 材質6 54 3,000 197 315,829 844,033 104,714 336,456 766,419 820,129 884,821 203,713 187,951 736,779
14 12345683 いりじゃこ 材質6 54 3,000 197 315,829 844,033 104,714 336,456 766,419 820,129 884,821 203,713 187,951 736,779
15 36363633 いか 材質16 58 6,000 808 91,653 193,268 342,336 502,936 226,905 498,093 574,588 863,187 999,670 383,124
作業用シート、使ってないので使いました、他にもＡ列当消したり してます。バックアップ取ってくださいね ＾＾； あってるか自信ないです。コレクションでソートなんか考えがよぎりましたが 私では無理そぉ、ソールマンさんの並び替え案を拝借。。。 挿入ロジック。。。むつかしそぉですが勉強の為 今からトライしてみましょうかね。。。でわ
Option Explicit
Sub 正方形長方形99_Click()
Dim ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim rr As Range
Dim i&, j&
Set ws2 = Sheets("作業シート")
Set ws3 = Sheets("data")
Set ws4 = Sheets("ツイン")
ws4.Range(ws4.Cells(2, 1), ws4.Cells.SpecialCells(xlLastCell)).Delete '前日分削除
ws3.Copy after:=Worksheets(1) '作業用ｼｰﾄ作成
With ActiveSheet
.Range("A:B,M:N,S:T,W:Y").Delete shift:=xlToLeft '不要行削除
Set rr = .Range("A1").CurrentRegion
Set rr = af(rr, 6, "<=550")
rr.Copy ws4.Range("B2") 'ツインシートに貼り付け
Set rr = .Range("A1").CurrentRegion
Set rr = af(rr, 4, ">=46")
rr.Copy ws2.Range("B2")
With ws4
For i = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row
.Cells(i, 1) = 1000000 + i
Next
End With
With ws2
For i = .Cells(.Rows.Count, 2).End(xlUp).Row To 2 Step -1
j = j + 1
.Cells(i, 1) = j
Next
Set rr = .Range("A2").CurrentRegion
rr.Copy ws4.Cells(ws4.Cells(ws4.Rows.Count, 2).End(xlUp).Row + 1, 1)
End With
With ws4
.Range("A2").CurrentRegion.Sort key1:=.Range("B2"), key2:=.Range("A2")
End With
If .FilterMode Then .ShowAllData
ws4.Range("A:A").Clear
ws2.UsedRange.Clear
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
ws4.Activate
End With
End Sub
Private Function af(ByVal rr As Range, ByVal f As Long, ByVal crt As String) As Variant
Dim lastrow1 As Long, ws1 As Worksheet
Set ws1 = ActiveSheet
If ws1.AutoFilterMode Then
ws1.Cells(1).AutoFilter
End If
With rr
.Range("A1", .Cells(.Count)).AutoFilter 'フィルターモード
.Range("A1").AutoFilter Field:=f, Criteria1:=crt
lastrow1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
Set af = ws1.Range(Cells(2, 1), ws1.Cells(lastrow1, 16)).SpecialCells(xlCellTypeVisible)
.Range("A1").AutoFilter
End With
End Function
（隠居じーさん） 2018/09/06(木) 08:37
。。。ん なにやら おおきなミスのよぉなきが A(^^; なにか Ｄ列のとらえ方を勘違いしているかもしれませんね。 ぶん さん の書込みを待ちます。。。
m( _ _ )m
（隠居じーさん） 2018/09/06(木) 08:48
であれば、ツインシートにすべて貼付したあとB列をキーにしてソートでいいですね。
ただ、
＞先に抽出したデータのＡ列で重複する数字の行の一番上に行挿入で貼り付けたいです。
なので、コピペする順を逆にしないとダメぽい気がします。
（もこな２） 2018/09/06(木) 09:10
Sub 正方形長方形1_Click()
Dim dstSH As Worksheet: Set dstSH = Sheets("ツイン")
Dim dstRNG As Range, tmp As Range
Stop
With dstSH
Set tmp = Intersect(.UsedRange, .UsedRange.Offset(1))
If Not tmp Is Nothing Then tmp.Delete '1行目以外を削除
Set dstRNG = .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
End With
Sheets("data").Copy after:=Worksheets(1)
With Worksheets(2)
.AutoFilterMode = False
.Range("A:B,M:N,S:T,W:Y").Delete shift:=xlToLeft
'D列が46以上のものを抽出して、項目行ごとツインシートへ貼付後、ツインシートに貼り付けた余分な項目行を削除
.Range("A1").AutoFilter Field:=4, Criteria1:=">=46", Operator:=xlAnd
.Range("A1").CurrentRegion.Copy dstRNG
dstRNG.EntireRow.Delete
'「dstRNG」の再セット
Set dstRNG = dstSH.Cells(dstSH.Rows.Count, "B").End(xlUp).Offset(1)
'オートフィルタを強制解除して抽出状態をクリアに
.AutoFilterMode = False
'F列が550以下のものを抽出して、項目行ごとツインシートへ貼付後、ツインシートに貼り付けた余分な項目行を削除
.Range("A1").AutoFilter Field:=6, Criteria1:="<=550", Operator:=xlAnd
.Range("A1").CurrentRegion.Copy dstRNG
dstRNG.EntireRow.Delete
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
'ツインシートのデータをB列：昇順で並び替え
With dstSH.Range("B1").CurrentRegion
.Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlYes
End With
End Sub
（もこな２） 2018/09/06(木) 12:30
情報量が少ないことから隠居じーさん様に推測をさせてしまい申し訳ありませんでした。
隠居じーさん様が考えてくださったコードではＦ列が550以下のＤ列が46以上のものがあった場合重複してツインのシートに表示されてしまいました。
もこな2様のコードを参考にさせて頂き少し修正すると希望通りの動作をしました。
お二人のコードの中には初めて見る配列もあり、とても勉強になりました。
ありがとうございました。
（ぶん） 2018/09/06(木) 14:34
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.