[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『該当期間の列を別シートに抽出するマクロ』（ななな）
立て続けに申し訳ありません。
特定の日付を指定し、該当期間に当てはまる列を別シートに抽出するマクロを組みたいと思っております。
＜シート：完成＞ A1セルに特定日
＜シート：名簿＞ N列：開始日、P列：終了日 この日付内から拾いたい
なお、シート内はVLOOKUPは多用しています。
抽出し、〇や✕を表示させるといった関数は見かけましたが、
上記についてどうぞよろしくお願い致します。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
要バックアップ ＾＾； 作ってみました。 情報が詳しくわかりませんのでお役には立たないと思いますが 何かの参考にでもなれば幸甚です。
オブジェクト名が「名簿」のシート 推測レイアウト
A B C D E F G H I J K L M N O P
1 項目 B1 C1 D1 E1 F1 G1 H1 I1 J1 K1 L1 M1 開始日 O1 終了日
2 10001 591 277 902 73 977 49 742 363 585 870 124 393 10月1日 10月7日
3 10002 571 481 23 486 347 889 676 84 198 428 894 912 10月2日 10月8日
4 10003 101 969 882 971 562 612 869 556 882 556 339 997 10月3日 10月9日
5 10004 643 794 251 799 82 928 408 566 241 630 558 934 10月4日 10月10日
6 10005 377 188 65 79 570 502 766 690 695 156 815 596 10月5日 10月11日
7 10006 13 313 120 867 859 924 291 646 688 397 933 762 10月6日 10月12日
8 10007 269 131 237 811 250 167 603 242 998 40 389 275 10月7日 10月13日
9 10008 496 41 823 759 633 403 933 447 22 846 416 370 10月8日 10月14日
10 10009 292 701 115 201 131 815 458 693 560 312 784 903 10月9日 11月2日
11 10010 47 79 229 899 990 320 478 969 660 970 774 402 10月10日 11月3日
12 10011 610 185 257 437 50 151 950 72 720 118 897 731 10月11日 11月4日
13 10012 880 84 329 29 126 409 507 544 149 814 316 893 10月12日 11月5日
14 10013 609 826 337 405 473 636 861 50 554 924 757 567 10月13日 11月6日
15 10014 898 149 60 147 157 532 586 335 657 132 336 980 10月14日 12月20日
16 10015 119 419 274 809 37 12 375 312 454 48 558 311 10月15日 1月14日
17 10016 131 974 705 142 390 905 81 330 268 559 335 607 10月16日 1月15日
18 10017 599 79 196 361 676 580 688 910 700 91 338 147 10月17日 1月16日
19 10018 288 485 626 722 436 788 294 869 821 116 508 821 10月18日 1月17日
20 10019 89 292 845 183 559 987 738 930 709 255 175 739 10月19日 1月18日
オブジェクト名が「完成」の結果レイアウト
A B C D E F G H I J K L M N O P
1 2018/10/12
2 10006 481 980 411 19 187 273 538 171 142 421 931 105 10月6日 10月12日
3 10007 845 626 488 18 740 334 127 247 58 827 953 177 10月7日 10月13日
4 10008 410 678 670 473 592 18 79 266 696 502 162 293 10月8日 10月14日
5 10009 140 66 529 505 408 28 747 74 809 818 789 653 10月9日 11月2日
6 10010 210 943 507 645 541 549 780 210 350 23 690 358 10月10日 11月3日
7 10011 407 580 72 339 68 196 414 819 361 330 179 762 10月11日 11月4日
8 10012 353 25 694 158 882 287 673 864 985 211 685 993 10月12日 11月5日
Option Explicit
Sub main()
Dim lr As Long, y As Long, rr As Range, r As Range, sh01 As Worksheet
Set sh01 = 名簿: y = 2
With 完成
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
lr = IIf(lr < 2, 2, lr)
.Rows("2:" & lr & "").Clear
Set rr = Intersect(sh01.Range("A1").CurrentRegion, _
sh01.Rows("2:" & sh01.Range("A1").CurrentRegion.Rows.Count & ""))
For Each r In rr.Rows
If .Cells(1) >= r.Cells(14) And .Cells(1) <= r.Cells(16) Then
r.Copy .Cells(y, 1)
r.Copy
.Cells(y, 1).PasteSpecial (xlValues)
y = y + 1
End If
Next
.Cells(1).Activate
End With
End Sub
（隠居じーさん） 2018/10/05(金) 17:02
（もこな２） 2018/10/05(金) 18:33
Option Explicit
Sub test()
Dim tbl As Range
Dim c As Range
Set tbl = Sheets("名簿").Range("A1").CurrentRegion
Set c = tbl.Range("A1:A2").Offset(, tbl.Columns.Count + 2)
c(2).Formula = "=and(N2<=完成!a1,p2>=完成!a1)"
Sheets("完成").UsedRange.Offset(1).ClearContents
tbl.AdvancedFilter xlFilterCopy, c, Sheets("完成").Range("A2")
c.ClearContents
End Sub
（マナ） 2018/10/05(金) 18:35
初心者故、至らぬ質問ばかりで申し訳ありません。
完成はすぐにできないと思いますが、またご報告させてください。
（ななな） 2018/10/09(火) 09:51
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.