Results of 1 - 1 of about 37655 for IF (0.008 sec.)
- [[20190207200453]]
- #score: 1592
- @digest: 55af2d9cbd733cd14cc4cfbdf98c8fc9
- @id: 78572
- @mdate: 2019-02-09T22:17:14Z
- @size: 61091
- @type: text/plain
- #keywords: 大期 (185731), 明[ (104359), 日| (55449), myb (53195), 明| (51961), myary (51101), mysary (42460), mydate (36551), 定| (34761), getdata (34647), 期間 (28644), 不明 (23549), 月8 (23065), mydic (21586), 月10 (19840), 日報 (18535), 間= (17272), ubound (16799), 月28 (16179), 区分 (15702), 月9 (15424), 予定 (13234), lbound (12262), 備考 (11382), preserve (9135), 月11 (9121), 時刻 (9014), 2019 (8906), 隠居 (8875), variant (8505), の予 (8277), soulman (7879)
- 『データの抽出』（日報）
お世話になります。 シート1、シート2の2つのシートがあります。 シート1 |[A] |[B] |[C] |[D] |[E] |[F] [1] |日付 |期間 |時刻|予定 |備考 |区分 [2] |1月3日 |不明 | |あ | |E [3] |1月10日|不明 | |あ | |D [4] |1月22日|不明 | |い | |E [5] |1月28日|不明 | |い | |D [6] |2月6日 |不明 | |あ |○○ |C [7] |2月8日 |2月9日 |1200|○○に出張|2月10日出勤|A [8] |2月11日|2月20日| |あ | |D [9] |2月8日 | | |い |○○ |C [10]|2月9日 | | 900|あ | |B [11]|2月8日 | |1330|う | |B [12]|2月8日 | |1100|い | |B [13]|2月10日| |1400|あ | |C [14]|2月8日 | |1330|あ | |B [15]|2月8日 | |1550|え | |B シート2 |[A] |[B] |[C] |[D] |[E] [1] | | |本日の予定| |2月8日(金) [2] |区分|時刻|予定 |備考 |期間 [3] |A |1200|○○に出張|2月10日出勤|2月9日 [4] | | | | | [5] |B |1000|あ | | [6] | |1100|い | | [7] | |1330|う | | [8] | |1550|え | | [9] | | | | | [10]|C | |あ |○○ |不明 [11]| | |い |○○ | [12]| | | | | [13]|D | |あ | |不明 [14]| | |い | |不明 [15]| | | | | [16]|E | |あ | | [17]| | |い | | ・シート1の予定からシート2のE1の日付の予定を抽出してシート2に貼り付け。 ・期間にデータが入力されている場合は、その日付が終わるまで抽出対象となる。（2月10日の日報には抽出しない） ・期間が不明の場合は、毎日抽出の対象とする。 ・シート2に転記する際、ABCDEの区分ごと、一つ空白行を入れて次の区分を転記する。（区分は実際にはABCDEではなく、シート3のA1〜E1にプルダウンリスト用として区分を入れています。そのA1〜E1の順番に転記したいです） ・時刻欄にデータがある場合、項目ごとに早い時刻から転記したい。（表示形式は標準の数値です） このような日報を作成したいのですが、マクロで可能でしょうか? ご教授お願いします。 ＜ 使用 Excel:Excel2010、使用 OS:Windows7 ＞ ---- ＞このような日報を作成したいのですが、マクロで可能でしょうか? いまいちされたいことがわかりませんけど、一定のルールに沿って抽出して貼付ているというのであれば、出来ると思いますよ。 必要な命令を調べるためにも、まずは手動操作を「マクロの記録」機能をつかってExcel君に仮のコードをつくってもらってみてはどうでしょうか （もこな2） 2019/02/07(木) 22:31 ---- Sheet3に↓とあったら E C A B D こうなったよ???? 本日の予定 2019/2/8 区分 時刻 予定 備考 期間 E あ 不明 い 不明 C あ ○○ 不明 い ○○ A 1200 ○○に出張 2月10日出勤 2019/2/9 B 900 あ 1100 い 1330 う 1330 あ 1550 え D あ 不明 い 不明 例によって思い付きですから、、、、 でも、、もう寝ますzzzzzzzzzzzzzzzzzzzz Option Explicit Sub てすと() Dim MyDic As Object Dim MyA As Variant Dim MyB As Variant Dim MyAry As Variant Dim MyDate As Date Dim 最大期間 As Date Dim 項目 As Variant Dim MyKey As String Dim x As Variant Dim y As Variant Dim z As Variant Dim v As Variant Dim r As Range Dim k As Long Dim i As Long Dim j As Long Set MyDic = CreateObject("Scripting.Dictionary") With Sheets("Sheet3") MyA = .Range("A1:E1").Value For j = LBound(MyA, 2) To UBound(MyA, 2) If Not MyDic.Exists(MyA(1, j)) Then Set MyDic(MyA(1, j)) = CreateObject("System.Collections.ArrayList") End If Next End With MyDate = Sheets("Sheet2").Range("E1").Value With Sheets("Sheet1") MyB = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 6).Value For i = LBound(MyB, 1) To UBound(MyB, 1) If MyB(i, 1) = MyDate Then If MyB(i, 2) > MyDate Then If Val(MyB(i, 2)) > 0 Then If 最大期間 < MyB(i, 2) Then 最大期間 = MyB(i, 2) End If End If End If Next If 最大期間 = 0 Then 最大期間 = MyDate For i = LBound(MyB, 1) To UBound(MyB, 1) If (MyB(i, 2) = "不明") + ((MyB(i, 1) >= MyDate) * (MyB(i, 1) <= 最大期間)) Then If MyDic.Exists(MyB(i, UBound(MyB, 2))) Then MyDic(MyB(i, UBound(MyB, 2))).Add Application.Index(MyB, i, 0) End If End If Next End With k = 1 ReDim MyAry(1 To 5, 1 To k) 項目 = Array("区分", "時刻", "予定", "備考", "期間") For i = LBound(項目) To UBound(項目) MyAry(i + 1, 1) = 項目(i) Next For Each z In MyDic If MyDic.Exists(z) Then x = MyDic(z).Toarray For i = LBound(x) To UBound(x) If MyKey <> z Then k = k + 1 ReDim Preserve MyAry(1 To 5, 1 To k) MyAry(1, k) = x(i)(6) MyAry(2, k) = x(i)(3) MyAry(3, k) = x(i)(4) MyAry(4, k) = x(i)(5) MyAry(5, k) = x(i)(2) k = k + 1 ReDim Preserve MyAry(1 To 5, 1 To k) MyKey = z Else MyAry(2, k) = x(i)(3) MyAry(3, k) = x(i)(4) MyAry(4, k) = x(i)(5) MyAry(5, k) = x(i)(2) k = k + 1 ReDim Preserve MyAry(1 To 5, 1 To k) End If Next End If Next With Sheets("Sheet2") v = .Range("C1:E1").Value .Cells.Clear .Range("C1:E1").Value = v .Range("A2").Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry) For Each r In Intersect(.Range("A:A"), .UsedRange) If r.Value <> "" Then If Application.Count(r.CurrentRegion.Cells(, 2).Resize(r.CurrentRegion.Rows.Count)) > 1 Then .Sort.SortFields.Clear .Sort.SortFields.Add Key:=r.CurrentRegion.Cells(, 2).Resize(r.CurrentRegion.Rows.Count) _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With .Sort .SetRange r.CurrentRegion .Header = xlGuess .SortMethod = xlPinYin .Apply End With End If End If Next End With Set MyDic = Nothing Erase MyA, MyB, MyAry, 項目, x, v End Sub （SoulMan） 2019/02/07(木) 23:44 ---- SoulManさん ありがとうございます。 希望の動作が出来ました。 （日報） 2019/02/08(金) 12:33 ---- すみません、確認したら、8日なのに9日のBの予定（900からの予定）が転記されています。 E1の日付を9日にしても転記されないです。 他にも動作確認してみます。 検証不足でコメントしてしまいすみませんでした。 （日報） 2019/02/08(金) 20:24 ---- >・期間にデータが入力されている場合は、その日付が終わるまで抽出対象となる。 期間に9日があるので10日は、抽出しませんが 9日は、抽出します （SoulMan） 2019/02/08(金) 21:06 ---- シート1の10行目の [10]|2月9日 | | 900|あ | |B これが8日に入ります。 （日報） 2019/02/08(金) 21:15 ---- >（2月10日の日報には抽出しない） だから、それでいいんじゃないんですか? （SoulMan） 2019/02/08(金) 21:43 ---- 最大期間が 0 で最初のループを抜けてくると、抽出しませんね(^^; これを↓追加しておきました。 If 最大期間 = 0 Then 最大期間 = MyDate 本日の予定 2019/2/9 区分 時刻 予定 備考 期間 E あ 不明 い 不明 C あ ○○ 不明 B 900 あ D あ 不明 い 不明 （SoulMan） 2019/02/08(金) 22:15 ---- ありがとうございます。 明日一で確認します。 ご迷惑おかけしました。 （日報） 2019/02/08(金) 22:28 ---- ちょっと眠れなかったので、暇つぶしに参加 の予定が結構はまったので楽しかったです。 にしても、書く人によって全然違うもんですねぇ。 勉強になります。 Option Explicit Sub test() Dim w As Variant 'Sheet1のデータ Dim dic As Variant, v As Variant 'Dictionaryと仮受け配列 Dim r As Range, i As Long, k As Variant 'For (Each)ステートメント用 Dim d As Date '日付比較用 Dim flg As Boolean '条件分岐 Dim n As Long '要素数 Dim Result As Range 'Sheet2の書き出し先 ' Set dic = CreateObject("Scripting.Dictionary") ReDim v(1 To 6, 1 To 1) ' 'Sheet3の区分を取り込む With Sheets("Sheet3") For Each r In .Range("A1", .Cells(1, Columns.Count).End(xlToLeft)) dic(r.Value) = v Next r End With ' 'Sheet1のデータ、Sheet2の日付取り込み w = Sheets("Sheet1").Range("F2", Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)) d = Sheets("Sheet2").Range("E1").Value ' 'dic(区分) = 二次配列(区分〜期間,行番号) For i = 1 To UBound(w, 1) flg = False Select Case True Case w(i, 1) = d: flg = True '日付が指定日と同じ Case w(i, 2) = "不明": flg = w(i, 1) <= d '不明且つ日付が指定日以下 Case IsDate(w(i, 2)): flg = w(i, 2) <= d '期間が日付且つ期間が指定日以下 End Select If flg Then v = dic(w(i, 6)) n = UBound(v, 2) + IIf(v(1, 1) <> "", 1, 0) ReDim Preserve v(1 To 6, 1 To n) v(1, n) = IIf(n = 1, w(i, 6), "") '1行目のみ区分 v(2, n) = w(i, 3) '時刻 v(3, n) = w(i, 4) '予定 v(4, n) = w(i, 5) '備考 v(5, n) = w(i, 2) '期間 v(6, n) = w(i, 1) '日付(ソート用 出力なし） dic(w(i, 6)) = v End If Next i ' 'Sheet2への書き出し準備 With Sheets("Sheet2") Set Result = .Range("A3") .Range("E3", .Cells(Rows.Count, "A")).ClearContents .Range("C1").Value = "本日の予定" .Range("A2:E2").Value = [{"区分","時刻","予定","備考","期間"}] End With ' '時間でバブルソートして、書き出し For Each k In dic.keys v = dic(k) If v(1, 1) <> "" Then Call bsort(v, Compare:=6, NotComp:=-1, ArySwapElemens:=Array(2, 3, 4, 5, 6)) '日付でソート Call bsort(v, Compare:=2, NotComp:=6, ArySwapElemens:=Array(2, 3, 4, 5, 6)) '日付の枠内で時間のソート Result.Resize(UBound(v, 2), UBound(v, 1) - 1).Value = Application.Transpose(v) '最終列の日付を除くデータを出力 Set Result = Result.Offset(UBound(v, 2) + 1) End If Next k Set dic = Nothing End Sub Private Sub bsort(ByRef w As Variant, ByVal Compare As Long, ByVal NotComp As Long, ByVal ArySwapElemens As Variant) '二次配列、二次元目用バブルソート Dim i As Long, j As Long, g As Variant, x As Variant 'Forステートメント用 Dim v As Variant '二次配列のスワップ用 Dim UB As Long, LB As Long '配列のはじめと終わり Dim flg As Boolean UB = UBound(w, 2) LB = LBound(w, 2) ReDim v(1 To UBound(w, 1)) For i = LB To UB For j = LB + 1 To UB - i + LB flg = False Select Case True Case -1: flg = True Case Else: flg = w(x, j) = w(x, j - 1) End Select If flg Then If w(Compare, j) < w(Compare, j - 1) Then For Each g In ArySwapElemens v(g) = w(g, j) w(g, j) = w(g, j - 1) w(g, j - 1) = v(g) Next g End If End If Next j Next i End Sub （稲葉） 2019/02/09(土) 01:04 ---- おはようございます。 答えを 稲葉さんのにあわせると、、、↓こうなりますけど、、、条件の考え方ですね(^^; まぁ、、、トピ主さんが正ですから、、、 Option Explicit Sub てすと() Dim MyDic As Object Dim MyA As Variant Dim MyB As Variant Dim MyAry As Variant Dim MyDate As Date Dim 最大期間 As Date Dim 項目 As Variant Dim MyKey As String Dim x As Variant Dim y As Variant Dim z As Variant Dim v As Variant Dim r As Range Dim k As Long Dim i As Long Dim j As Long Set MyDic = CreateObject("Scripting.Dictionary") With Sheets("Sheet3") MyA = .Range("A1:E1").Value For j = LBound(MyA, 2) To UBound(MyA, 2) If Not MyDic.Exists(MyA(1, j)) Then Set MyDic(MyA(1, j)) = CreateObject("System.Collections.ArrayList") End If Next End With MyDate = Sheets("Sheet2").Range("E1").Value With Sheets("Sheet1") MyB = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, 6).Value For i = LBound(MyB, 1) To UBound(MyB, 1) ' If MyB(i, 1) = MyDate Then ' If MyB(i, 2) > MyDate Then ' If Val(MyB(i, 2)) > 0 Then ' If 最大期間 < MyB(i, 2) Then 最大期間 = MyB(i, 2) ' End If ' End If ' End If If IsEmpty(MyB(i, 3)) Then MyB(i, 3) = 0 Next QuickSort MyB, 3, LBound(MyB, 1), UBound(MyB, 1) ' If 最大期間 = 0 Then 最大期間 = MyDate For i = LBound(MyB, 1) To UBound(MyB, 1) ' If (MyB(i, 2) = "不明") + ((MyB(i, 1) >= MyDate) * (MyB(i, 1) <= 最大期間)) Then '日付と期間内といことなら If (MyB(i, 2) = "不明") + (MyB(i, 1) = MyDate) + (MyB(i, 2) = MyDate) Then If MyDic.Exists(MyB(i, UBound(MyB, 2))) Then MyDic(MyB(i, UBound(MyB, 2))).Add Application.Index(MyB, i, 0) End If End If Next End With k = 1 ReDim MyAry(1 To 5, 1 To k) 項目 = Array("区分", "時刻", "予定", "備考", "期間") For i = LBound(項目) To UBound(項目) MyAry(i + 1, 1) = 項目(i) Next For Each z In MyDic If MyDic.Exists(z) Then x = MyDic(z).ToArray For i = LBound(x) To UBound(x) If MyKey <> z Then k = k + 1 ReDim Preserve MyAry(1 To 5, 1 To k) MyAry(1, k) = x(i)(6) MyAry(2, k) = x(i)(3) MyAry(3, k) = x(i)(4) MyAry(4, k) = x(i)(5) MyAry(5, k) = x(i)(2) k = k + 1 ReDim Preserve MyAry(1 To 5, 1 To k) MyKey = z Else MyAry(2, k) = x(i)(3) MyAry(3, k) = x(i)(4) MyAry(4, k) = x(i)(5) MyAry(5, k) = x(i)(2) k = k + 1 ReDim Preserve MyAry(1 To 5, 1 To k) End If Next End If Next With Sheets("Sheet2") v = .Range("C1:E1").Value .Cells.Clear .Range("C1:E1").Value = v .Range("A2").Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry) .Range("B3").Resize(UBound(MyAry, 2)).NumberFormat = "#" .Range("E3").Resize(UBound(MyAry, 2)).NumberFormat = "m月d日" End With Set MyDic = Nothing Erase MyA, MyB, MyAry, 項目, x, v End Sub Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal MySRight As Long) Dim MySMid As Double Dim i As Long, j As Long, n As Long Dim MySLBound As Long, MySUBound As Long Dim MyStmp As String MySLBound = LBound(MySAry, 2) MySUBound = UBound(MySAry, 2) MySMid = MySAry((MySLeft + MySRight) ¥ 2, MySKey) i = MySLeft j = MySRight Do Do While MySAry(i, MySKey) < MySMid i = i + 1 Loop Do While MySAry(j, MySKey) > MySMid j = j - 1 Loop If i >= j Then Exit Do For n = MySLBound To MySUBound MyStmp = MySAry(i, n) MySAry(i, n) = MySAry(j, n) MySAry(j, n) = MyStmp Next i = i + 1 j = j - 1 Loop If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1 If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight End Sub （SoulMan） 2019/02/09(土) 07:36 ---- あれ、条件何か違いました?! 出力結果同じだったので、詳しく検証してませんでした2/8の場合 あとで直す予定だったところは、期間が不明のところを 無条件でリストに載せたので、日付がE1以下を追加しようかなと思ってました パソコン開いたら見てみます てか、雪で帰れるかな、、、 （稲葉） 2019/02/09(土) 07:51 ---- >あれ、条件何か違いました?! 私は最初に見たときに、 >・期間にデータが入力されている場合は、その日付が終わるまで抽出対象となる。（2月10日の日報には抽出しない） ということは、、9日は抽出すると考えたのですが、、、ご提示の 解 に 9日が入っていなかったので >こうなったよ???? と、なったのです。 当初の思いとしては、、、↓この辺の条件をご自身でお好みにアレンジしてくれたらなぁ、、と思っていました。 ' If (MyB(i, 2) = "不明") + ((MyB(i, 1) >= MyDate) * (MyB(i, 1) <= 最大期間)) Then '日付と期間内といことなら If (MyB(i, 2) = "不明") + (MyB(i, 1) = MyDate) + (MyB(i, 2) = MyDate) Then If MyDic.Exists(MyB(i, UBound(MyB, 2))) Then MyDic(MyB(i, UBound(MyB, 2))).Add Application.Index(MyB, i, 0) End If End If >にしても、書く人によって全然違うもんですねぇ。 同感です。(^^; 勉強になります。 そう考えると、トピ主さんも ヒントを得たら、、オリジナル がいいでしょうね(笑) >てか、雪で帰れるかな、、、 お気をつけて、、おかえりなさいまし。 では、では、 （SoulMan） 2019/02/09(土) 08:13 ---- ＞ >・期間にデータが入力されている場合は、その日付が終わるまで抽出対象となる。（2月10日の日報には抽出しない） ＞ということは、、9日は抽出すると考えたのですが、、、ご提示の 解 に 9日が入っていなかったので 私は、 シート1の [7] |2月8日 |2月9日 |1200|○○に出張|2月10日出勤|A ‾‾‾‾‾‾‾ がサンプルと考え、 日付＜=期間をリストアップすると考えていました。 ＞ ・時刻欄にデータがある場合、項目ごとに早い時刻から転記したい。（表示形式は標準の数値です） これについては、期間と時間が同時に入力された場合は対応できないので、どうしようかなーとは思ってます。 この投稿のあと、前回のコード書き換えてきます。 （稲葉） 2019/02/09(土) 09:28 ---- おはようございます。(#^.^#) 遅くなりましたが。。。参加します。 ソート解りませんがすごく興味が有り お二方、先生のコード、勉強中です。 とりあえず、エクセル様のソートで。。。 あと 当初、日報さんがご提示の Sheet2の★[5] |B |1000|あ | | ← どこから来たのでしょうか よくわかりません。 コード!、間違っていましたらお許しを。。。(￣▽￣;)。。。m(_ _)m Option Explicit Sub main() Dim s1 As Worksheet Dim s2 As Worksheet Dim s3 As Worksheet Dim i As Long Dim y As Long Dim x As Long Dim kubun Dim S_Day As Date Dim Wflg As Boolean Dim midasi Dim rr As Range Dim r As Range Dim BK As String Set s1 = Worksheets("Sheet1") Set s2 = Worksheets("Sheet2") Set s3 = Worksheets("Sheet3") kubun = s3.Range("A1:E1") Set rr = s1.Range("A1").CurrentRegion y = 3 With s2 '情報抽出 midasi = .Range("A1:E2") S_Day = .Range("E1").Value .Cells.Delete .Cells(1).Resize(2, 5) = midasi For i = 2 To rr.Rows.Count If rr(i, 2) = "不明" Then Wflg = True ElseIf rr(i, 2) = "" Then If rr(i, 1) = S_Day Then Wflg = True End If ElseIf TypeName(rr(i, 2).Value) = "Date" Then If S_Day >= rr(i, 1) And S_Day <= rr(i, 2) Then Wflg = True End If End If If Wflg Then .Cells(y, 1) = rr(i, 6) .Cells(y, 2) = rr(i, 3) .Cells(y, 3) = rr(i, 4) .Cells(y, 4) = rr(i, 5) .Cells(y, 5) = rr(i, 2) If TypeName(.Cells(y, 5).Value) = "Double" Then .Cells(y, 5).NumberFormatLocal = "m月d日" y = y + 1 Wflg = False End If Next 'SORT Set r = .Cells(1).CurrentRegion Set rr = Intersect(r, .Range(.Rows(2), .Rows(r.Rows.Count))) rr.Sort key1:=rr(1, 1), Order1:=xlAscending, key2:=rr(1, 2), Order2:=xlAscending, Header:=xlYes '区分別一行挿入処理 BK = .Cells(rr.Rows.Count, 1) For i = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1 If .Cells(i, 1) <> BK Then .Rows(i).Offset(1).Insert End If BK = .Cells(i, 1) Next rr.EntireColumn.AutoFit End With End Sub （隠居じーさん） 2019/02/09(土) 11:06 ---- 上のを書き直そうかと思いましたが、隠居じーさん さんもいらっしゃたことですし、、新たにUpします。 楽しいですねぇ(笑) やっと稲葉さんの答えとあってきましたけど、、並びがちょっと違う(^^; >・時刻欄にデータがある場合、項目ごとに早い時刻から転記したい。（表示形式は標準の数値です） これにも対応しておきました。 Option Explicit Sub てすと() Dim MyDic As Object Dim MyA As Variant Dim MyB As Variant Dim MyAry As Variant Dim MyDate As Date Dim 最大期間 As Date Dim 項目 As Variant Dim MyKey As String Dim x As Variant Dim y As Variant Dim z As Variant Dim v As Variant Dim r As Range Dim k As Long Dim i As Long Dim j As Long Set MyDic = CreateObject("Scripting.Dictionary") With Sheets("Sheet3") MyA = .Range("A1:E1").Value For j = LBound(MyA, 2) To UBound(MyA, 2) If Not MyDic.Exists(MyA(1, j)) Then Set MyDic(MyA(1, j)) = CreateObject("System.Collections.ArrayList") End If Next End With MyDate = Sheets("Sheet2").Range("E1").Value With Sheets("Sheet1") MyB = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, 6).Value For i = LBound(MyB, 1) To UBound(MyB, 1) If MyB(i, 1) = MyDate Then If MyB(i, 2) > MyDate Then If Val(MyB(i, 2)) > 0 Then If 最大期間 < MyB(i, 2) Then 最大期間 = MyB(i, 2) End If End If End If If IsEmpty(MyB(i, 3)) Then MyB(i, 3) = 0 Next QuickSort MyB, 3, LBound(MyB, 1), UBound(MyB, 1) If 最大期間 = 0 Then 最大期間 = MyDate For i = LBound(MyB, 1) To UBound(MyB, 1) If MyB(i, 2) <> "" Then If (MyB(i, 2) = "不明") + ((MyB(i, 2) <= 最大期間)) Then If MyDic.Exists(MyB(i, UBound(MyB, 2))) Then MyDic(MyB(i, UBound(MyB, 2))).Add Application.Index(MyB, i, 0) End If End If ElseIf MyB(i, 1) = MyDate Then If MyDic.Exists(MyB(i, UBound(MyB, 2))) Then MyDic(MyB(i, UBound(MyB, 2))).Add Application.Index(MyB, i, 0) End If End If Next End With k = 1 ReDim MyAry(1 To 5, 1 To k) 項目 = Array("区分", "時刻", "予定", "備考", "期間") For i = LBound(項目) To UBound(項目) MyAry(i + 1, 1) = 項目(i) Next For Each z In MyDic If MyDic.Exists(z) Then x = MyDic(z).ToArray For i = LBound(x) To UBound(x) If MyKey <> z Then k = k + 1 ReDim Preserve MyAry(1 To 5, 1 To k) MyAry(1, k) = x(i)(6) If x(i)(3) = 0 Then x(i)(3) = "" MyAry(2, k) = x(i)(3) MyAry(3, k) = x(i)(4) MyAry(4, k) = x(i)(5) MyAry(5, k) = x(i)(2) k = k + 1 ReDim Preserve MyAry(1 To 5, 1 To k) MyKey = z Else If x(i)(3) = 0 Then x(i)(3) = "" MyAry(2, k) = x(i)(3) MyAry(3, k) = x(i)(4) MyAry(4, k) = x(i)(5) MyAry(5, k) = x(i)(2) k = k + 1 ReDim Preserve MyAry(1 To 5, 1 To k) End If Next End If Next With Sheets("Sheet2") v = .Range("C1:E1").Value .Cells.Clear .Range("C1:E1").Value = v .Range("A2").Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry) .Range("E3").Resize(UBound(MyAry, 2)).NumberFormat = "m月d日" End With Set MyDic = Nothing Erase MyA, MyB, MyAry, 項目, x, v End Sub Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal MySRight As Long) Dim MySMid As Double Dim i As Long, j As Long, n As Long Dim MySLBound As Long, MySUBound As Long Dim MyStmp As String MySLBound = LBound(MySAry, 2) MySUBound = UBound(MySAry, 2) MySMid = MySAry((MySLeft + MySRight) ¥ 2, MySKey) i = MySLeft j = MySRight Do Do While MySAry(i, MySKey) < MySMid i = i + 1 Loop Do While MySAry(j, MySKey) > MySMid j = j - 1 Loop If i >= j Then Exit Do For n = MySLBound To MySUBound MyStmp = MySAry(i, n) MySAry(i, n) = MySAry(j, n) MySAry(j, n) = MyStmp Next i = i + 1 j = j - 1 Loop If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1 If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight End Sub （SoulMan） 2019/02/09(土) 11:13 ---- 私も先ほどちょっとだけブラッシュアップしました。 ソートコードいじって、日付昇順且つ期間昇順にしました。 SoulManさんと違うところは（2/8ベースで）、区分Dの予定が、「あ;い」と「い;あ」ですかねぇ。 隠居じーさんさんのは ・Sheet3の並び順になっていない ・区分が連続するとき、2行目以降が空白になっていない ・2/8だとわかりにくいですが、期間が不明の場合、日付に関係なく出力される If rr(i, 2) = "不明" Then Wflg = True が気になりましたねー （稲葉） 2019/02/09(土) 11:23 ---- おはようございます ^^ ＞＞楽しいですねぇ(笑) はい。。。^^; 今日は土曜で御馬さん日ですか。 稲葉さん、おはようございます。ありがとうございます 早速、確認してみますです。 2019/2/15 で抽出すると。。。三人三様。。。なのですが。。。 w 自信が無くなってきました。。。← 私の場合（最初からありませんけど（笑）） でわでわ m(_ _)m （隠居じーさん） 2019/02/09(土) 11:39 ---- おはようございます。 >今日は土曜で御馬さん日ですか。 今日は、ひらめかないので 学校で暇つぶしです。(^^; >SoulManさんと違うところは（2/8ベースで）、区分Dの予定が、「あ;い」と「い;あ」ですかねぇ。 どうも、、あ;い の方が良さそうなので、、、結局、、最初にひらめいたコードに戻って、、並び替えは、、チマチマversionです。 Option Explicit Sub てすと() Dim MyDic As Object Dim MyA As Variant Dim MyB As Variant Dim MyAry As Variant Dim MyDate As Date Dim 最大期間 As Date Dim 項目 As Variant Dim MyKey As String Dim x As Variant Dim y As Variant Dim z As Variant Dim v As Variant Dim r As Range Dim k As Long Dim i As Long Dim j As Long Dim MyFlg As Boolean Set MyDic = CreateObject("Scripting.Dictionary") With Sheets("Sheet3") MyA = .Range("A1:E1").Value For j = LBound(MyA, 2) To UBound(MyA, 2) If Not MyDic.Exists(MyA(1, j)) Then Set MyDic(MyA(1, j)) = CreateObject("System.Collections.ArrayList") End If Next End With MyDate = Sheets("Sheet2").Range("E1").Value With Sheets("Sheet1") MyB = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, 6).Value For i = LBound(MyB, 1) To UBound(MyB, 1) If MyB(i, 1) = MyDate Then If MyB(i, 2) > MyDate Then If Val(MyB(i, 2)) > 0 Then If 最大期間 < MyB(i, 2) Then 最大期間 = MyB(i, 2) End If End If End If Next If 最大期間 = 0 Then 最大期間 = MyDate For i = LBound(MyB, 1) To UBound(MyB, 1) If MyB(i, 2) <> "" Then If (MyB(i, 2) = "不明") + ((MyB(i, 2) <= 最大期間)) Then MyFlg = True ElseIf MyB(i, 1) = MyDate Then MyFlg = True End If If MyFlg Then If MyDic.Exists(MyB(i, UBound(MyB, 2))) Then MyDic(MyB(i, UBound(MyB, 2))).Add Application.Index(MyB, i, 0) End If MyFlg = False End If Next End With k = 1 ReDim MyAry(1 To 5, 1 To k) 項目 = Array("区分", "時刻", "予定", "備考", "期間") For i = LBound(項目) To UBound(項目) MyAry(i + 1, 1) = 項目(i) Next For Each z In MyDic If MyDic.Exists(z) Then x = MyDic(z).Toarray For i = LBound(x) To UBound(x) If MyKey <> z Then k = k + 1 ReDim Preserve MyAry(1 To 5, 1 To k) MyAry(1, k) = x(i)(6) MyAry(2, k) = x(i)(3) MyAry(3, k) = x(i)(4) MyAry(4, k) = x(i)(5) MyAry(5, k) = x(i)(2) k = k + 1 ReDim Preserve MyAry(1 To 5, 1 To k) MyKey = z Else MyAry(2, k) = x(i)(3) MyAry(3, k) = x(i)(4) MyAry(4, k) = x(i)(5) MyAry(5, k) = x(i)(2) k = k + 1 ReDim Preserve MyAry(1 To 5, 1 To k) End If Next End If Next With Sheets("Sheet2") v = .Range("C1:E1").Value .Cells.Clear .Range("C1:E1").Value = v .Range("A2").Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry) For Each r In Intersect(.Range("A:A"), .UsedRange) If r.Value <> "" Then If Application.Count(r.CurrentRegion.Cells(, 2).Resize(r.CurrentRegion.Rows.Count)) > 1 Then MyKey = r.Value .Sort.SortFields.Clear .Sort.SortFields.Add Key:=r.CurrentRegion.Cells(, 2).Resize(r.CurrentRegion.Rows.Count) _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With .Sort .SetRange r.CurrentRegion .Header = xlGuess .SortMethod = xlPinYin .Apply End With r.CurrentRegion.Cells(1).Resize(r.CurrentRegion.Rows.Count).Clear r.CurrentRegion.Cells(1).Value = MyKey End If End If Next End With Set MyDic = Nothing Erase MyA, MyB, MyAry, 項目, x, v End Sub 追加のところがもっさりとしていましたのでFlgを追加してみました。 （SoulMan） 2019/02/09(土) 11:45 ---- 衝突! うーーーん... ロジックはあってると思いますが結果がどうしても違う... Sub test() Dim a, i As Long, myDate As Date, dic As Object Set dic = CreateObject("Scripting.Dictionary") myDate = [sheet2!e1] a = Sheets("sheet3").Cells(1).CurrentRegion.Value For i = 1 To UBound(a, 2) If a(1, i) <> "" Then dic(a(1, i)) = Empty Next With Sheets("sheet1").Cells(1).CurrentRegion a = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), [{6,3,4,5,2,1}]) End With For i = 2 To UBound(a, 1) If a(i, 5) <> "" Then If a(i, 5) = "不明" Then GetData dic, a, i ElseIf IsDate(a(i, 5)) Then If a(i, 5) >= myDate Then GetData dic, a, i End If Else If a(i, 6) = myDate Then GetData dic, a, i End If Next GetOutPut a, dic End Sub Private Sub GetData(dic, a, i) Dim w, ii As Long If IsEmpty(dic(a(i, 1))) Then Set dic(a(i, 1)) = CreateObject("System.Collections.SortedList") End If If Not dic(a(i, 1)).Contains(Val(a(i, 2))) Then ReDim w(1 To UBound(a, 2) - 1, 1 To 1) Else w = dic(a(i, 1))(Val(a(i, 2))) ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1) End If For ii = 2 To UBound(w, 1) w(ii, UBound(w, 2)) = a(i, ii) Next dic(a(i, 1))(Val(a(i, 2))) = w End Sub Private Sub GetOutPut(a, dic) Dim e, i As Long, ii As Long, iii As Long, n As Long With Sheets("sheet2").[a2].Resize(, UBound(a, 2) - 1) .Resize(10000).ClearContents .Value = a ReDim a(1 To UBound(a, 1) ^ 2, 1 To UBound(a, 2) - 1) For Each e In dic If Not IsEmpty(dic(e)) Then n = n + 1: a(n, 1) = e: n = n - 1 For i = 0 To dic(e).Count - 1 For ii = 1 To UBound(dic(e).GetByIndex(i), 2) n = n + 1 For iii = 2 To UBound(dic(e).GetByIndex(i), 1) a(n, iii) = dic(e).GetByIndex(i)(iii, ii) Next Next Next n = n + 1 End If Next .Rows(2).Resize(n) = a End With End Sub （seiya） 2019/02/09(土) 12:38 ---- ソートフィールド使うなら、フィルタオプションも面白いですよね! だいぶ短くなったぁ Sub inaba2() Dim ws2 As Worksheet Dim i As Long Dim r As String Set ws2 = Sheets("Sheet2") With ws2 '抽出条件 .Range("K1:L4").Value = Application.Evaluate(WorksheetFunction.Substitute("{""日付"",""期間"";""■"","""";""<=■"",""不明"";""<=■"",""<=■""}", "■", [Sheet2!E1])) .Range("A2:F2").Value = [{"区分","時刻","予定","備考","期間","日付"}] .Range("E3", .Cells(Rows.Count, "A")).ClearContents '抽出 Sheets("Sheet1").Range("F1", Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)).AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=.Range("K1:L4"), _ CopyToRange:=.Range("A2:F2"), _ Unique:=False With .Sort.SortFields '並び替え .Clear .Add Key:=ws2.Range("A2"), CustomOrder:=Join([Sheet3!A1:E1&""], ",") '区分をSheet3のA1:E1の順に並べ替え .Add Key:=ws2.Range("F2") '日付を昇順で並べ替え .Add Key:=ws2.Range("B2") '時刻を昇順で並べ替え End With With .Sort .SetRange ws2.Range("F2", ws2.Cells(Rows.Count, "A").End(xlUp)) '並べ替え範囲を設定 .Header = xlYes '先頭行を見出しとして使用 .Apply '並べ替えを実行 End With '並べ替えで不要になった日付列削除 .Range("F:L").ClearContents '区分間のスペースと一文字のみ For i = .Cells(Rows.Count, "A").End(xlUp).Row To 4 Step -1 If .Cells(i, "A").Value <> .Cells(i - 1, "A").Value Then r = r & "," & .Rows(i).Address(0, 0) Else .Cells(i, "A").Value = "" End If Next i If r <> "" Then Range(Mid$(r, 2)).Insert shift:=xlDown End With End Sub （稲葉） 2019/02/09(土) 12:54 ---- seiyaさんの2/8時点で ＞ [8] |2月11日|2月20日| |あ | |D が入っちゃってるってことは、 期間に何か入力されているときに、強制的にリスト化されちゃってる感じですかね? 試しに2/6で実行すると ＞[7] |2月8日 |2月9日 |1200|○○に出張|2月10日出勤|A こっちもリスト化されちゃうので、たぶんそうかと（コード ×読んでない ○読めない） （稲葉） 2019/02/09(土) 12:59 ---- ということは A列の日付がSheet2!E1よりも以前ということが第一条件? でも、提示された結果とちょっと違ってますね... 読解力が乏しくて... Sub test() Dim a, i As Long, myDate As Date, dic As Object Set dic = CreateObject("Scripting.Dictionary") myDate = [sheet2!e1] a = Sheets("sheet3").Cells(1).CurrentRegion.Value For i = 1 To UBound(a, 2) If a(1, i) <> "" Then dic(a(1, i)) = Empty Next With Sheets("sheet1").Cells(1).CurrentRegion a = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), [{6,3,4,5,2,1}]) End With For i = 2 To UBound(a, 1) If a(i, 6) = myDate Then GetData dic, a, i ElseIf a(i, 6) < myDate Then If a(i, 5) <> "" Then If a(i, 5) = "不明" Then GetData dic, a, i ElseIf IsDate(a(i, 5)) Then If a(i, 5) >= myDate Then GetData dic, a, i End If End If End If Next GetOutPut a, dic End Sub （seiya） 2019/02/09(土) 13:35 ---- ＞ A列の日付がSheet2!E1よりも以前ということが第一条件? だと思うんですよね・・・。 ＞ [5] |B |1000|あ | | これはおそらく誤り（シート1にないデータ） なので、抽出条件設定はこのようにしました。 |[K] |[L] |[M] [1]|日付 |期間 | [2]|2019/2/6 | |日付が指定日 [3]|<=2019/02/06|不明 |日付が指定日以前且つ期間が不明の場合は、抽出の対象とする。 [4]|<=2019/02/06|<=2019/02/06|日付が指定日以前且つ期間が指定日以前 （稲葉） 2019/02/09(土) 13:52 ---- 皆様ありがとうございます。 ちょっとコメ数が伸びててびっくりしてます。 見てて申し訳ないので条件を煮詰めて、しっかり説明できるものを提示します。 夕方になると思います。 本当にありがとうございます。 （日報） 2019/02/09(土) 14:06 ---- またまた衝突... ですよね...Bのタイプだけ違った出力になってますが(元が違ってる?)。 私はここまでとします。 稲葉さん、検証ありがとうございました。 （seiya） 2019/02/09(土) 14:09 ---- こんにちは ^^ なんか。。。いつの間にか、すごいことになっていますね。 ご指摘の点修正版です ^^; たしかに、そぉですよね 期間の並び替えまではやっていません。（ご注文には無かったような気が ^^;） でわ Option Explicit Sub New_main() Dim s1 As Worksheet Dim s2 As Worksheet Dim s3 As Worksheet Dim i As Long Dim y As Long Dim x As Long Dim kubun Dim S_Day As Date Dim Wflg As Boolean Dim midasi Dim rr As Range Dim r As Range Dim BK As String Set s1 = Worksheets("Sheet1") Set s2 = Worksheets("Sheet2") Set s3 = Worksheets("Sheet3") kubun = s3.Range("A1:E1") Set rr = s1.Range("A1").CurrentRegion y = 3 With s2 '情報抽出 midasi = .Range("A1:E2") S_Day = .Range("E1").Value .Cells.Delete .Cells(1).Resize(2, 5) = midasi For i = 2 To rr.Rows.Count If rr(i, 2) = "不明" Then If rr(i, 1) < S_Day Then Wflg = True End If ElseIf rr(i, 2) = "" Then If rr(i, 1) = S_Day Then Wflg = True End If ElseIf TypeName(rr(i, 2).Value) = "Date" Then If S_Day >= rr(i, 1) And S_Day <= rr(i, 2) Then Wflg = True End If End If If Wflg Then .Cells(y, 1) = rr(i, 6) .Cells(y, 2) = rr(i, 3) .Cells(y, 3) = rr(i, 4) .Cells(y, 4) = rr(i, 5) .Cells(y, 5) = rr(i, 2) If TypeName(.Cells(y, 5).Value) = "Double" Then .Cells(y, 5).NumberFormatLocal = "m月d日" y = y + 1 Wflg = False End If Next 'SORT For i = 3 To .Cells(.Rows.Count, 1).End(xlUp).Row For x = 1 To UBound(kubun, 2) If .Cells(i, 1) = kubun(1, x) Then .Cells(i, 1) = x End If Next Next Set r = .Cells(1).CurrentRegion Set rr = Intersect(r, .Range(.Rows(2), .Rows(r.Rows.Count))) rr.Sort key1:=rr(1, 1), Order1:=xlAscending, key2:=rr(1, 2), Order2:=xlAscending, Header:=xlYes For i = 3 To .Cells(.Rows.Count, 1).End(xlUp).Row For x = 1 To UBound(kubun, 2) If .Cells(i, 1) = x Then .Cells(i, 1) = kubun(1, x) End If Next Next '区分別一行挿入処理 BK = .Cells(rr.Rows.Count, 1) For i = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1 If .Cells(i, 1) <> BK Then .Rows(i).Offset(1).Insert End If BK = .Cells(i, 1) Next For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 3 Step -1 If .Cells(i, 1) = .Cells(i, 1).Offset(-1) Then .Cells(i, 1) = "" End If Next rr.EntireColumn.AutoFit End With End Sub （隠居じーさん） 2019/02/09(土) 14:11 ---- seiyaさん こちらこそ、ありがとうございました。 まとまった時間が取れたら、コードちゃんと読ませてもらいます。 日報さん あとは全部使ってみて、どこがどう違うのか、説明いただくだけですよ。 なので、これ以上条件に詰めてもらう必要はないです。 トライアンドエラーで行きましょう。 新しい条件が増えそうだったら連絡してください。 私のコードは （稲葉） 2019/02/09(土) 12:54 の投稿が一番わかりやすいと思うので、そちらで検証お願いします。 隠居じーさんさん すみません、私のは日付昇順且つ「時刻」昇順の間違いでした。すみません。 （稲葉） 2019/02/09(土) 14:17 ---- ＞＞すみません、私のは日付昇順且つ「時刻」昇順の間違いでした。すみません。 いえ、とんでもありません こちらこそ、いつも勉強させていただいております。 ご検証、有難うございました。また宜しくお願い致します。 m(_ _)m （隠居じーさん） 2019/02/09(土) 14:29 ---- （隠居じーさん） 2019/02/09(土) 14:11 隠居じーさんさんのコードで出来ました。 ただ、実行すると列幅が文字数に調整されたりフォームコントロールボタン等のオブジェクトが消えてしまいます。 Deleteの部分かと思ったんですが、違いましたね… seiyaさんの2つ目のコード （seiya） 2019/02/09(土) 13:35 ですが、コンパイルエラー:SubまたはFunctionが定義されてませんと出ます。 すごいシンプルなコードなので気になります…。 SoulManさん、稲葉さん本当にありがとうございます。 VBAは勉強を始めたばかりで、ようやく簡単なFor文を使ったりとか変数に格納してみたりとか。 今回の皆様のコードが本当に凄くて、（凄すぎて殆ど理解できないですが）これからも勉強させてもらいます。 本当にありがとうございます。 （日報） 2019/02/09(土) 19:38 ---- seiyaさんのコードは、 （seiya） 2019/02/09(土) 12:38 に投稿された残りの2つ、Getdataとgetoutputを同じブックにいれないと使えませんよ ちなみに、私のコードは希望の形にならなかった、ということですか? （稲葉） 2019/02/09(土) 19:45 ---- 修正分だけ載せたので... 一応、全コードです Sub test() Dim a, i As Long, myDate As Date, dic As Object Set dic = CreateObject("Scripting.Dictionary") myDate = [sheet2!e1] a = Sheets("sheet3").Cells(1).CurrentRegion.Value For i = 1 To UBound(a, 2) If a(1, i) <> "" Then dic(a(1, i)) = Empty Next With Sheets("sheet1").Cells(1).CurrentRegion a = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), [{6,3,4,5,2,1}]) End With For i = 2 To UBound(a, 1) If a(i, 6) = myDate Then GetData dic, a, i ElseIf a(i, 6) < myDate Then If a(i, 5) <> "" Then If a(i, 5) = "不明" Then GetData dic, a, i ElseIf IsDate(a(i, 5)) Then If a(i, 5) >= myDate Then GetData dic, a, i End If End If End If Next GetOutPut a, dic End Sub Private Sub GetData(dic, a, i) Dim w, ii As Long If IsEmpty(dic(a(i, 1))) Then Set dic(a(i, 1)) = CreateObject("System.Collections.SortedList") End If If Not dic(a(i, 1)).Contains(Val(a(i, 2))) Then ReDim w(1 To UBound(a, 2) - 1, 1 To 1) Else w = dic(a(i, 1))(Val(a(i, 2))) ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1) End If For ii = 2 To UBound(w, 1) w(ii, UBound(w, 2)) = a(i, ii) Next dic(a(i, 1))(Val(a(i, 2))) = w End Sub Private Sub GetOutPut(a, dic) Dim e, i As Long, ii As Long, iii As Long, n As Long With Sheets("sheet2").[a2].Resize(, UBound(a, 2) - 1) .Resize(10000).ClearContents .Value = a ReDim a(1 To UBound(a, 1) ^ 2, 1 To UBound(a, 2) - 1) For Each e In dic If Not IsEmpty(dic(e)) Then n = n + 1: a(n, 1) = e: n = n - 1 For i = 0 To dic(e).Count - 1 For ii = 1 To UBound(dic(e).GetByIndex(i), 2) n = n + 1 For iii = 2 To UBound(dic(e).GetByIndex(i), 1) a(n, iii) = dic(e).GetByIndex(i)(iii, ii) Next Next Next n = n + 1 End If Next .Rows(2).Resize(n) = a End With End Sub （seiya） 2019/02/09(土) 19:58 ---- 衝突しました。 稲葉さんありがとうございます。 転記してもいつの日付か分かるように予定欄に日付を入れてテストしてます。 いろいろ検証してて最初とレイアウトが違いますが…… シート1 |[A] |[B] |[C] |[D] |[E] |[F] [1] |日付 |期間 |時刻|予定 |備考 |区分 [2] |1月3日 |不明 | |1月3日 | |E [3] |1月10日|不明 | |1月10日| |D [4] |1月22日|不明 | |1月22日| |E [5] |1月28日|不明 | |1月28日| |D [6] |2月6日 |不明 | |2月6日 |○○ |C [7] |2月8日 |2月9日 |1200|2月8日 |2月10日出勤|A [8] |2月11日|2月20日| |2月11日| |D [9] |2月8日 | | |2月8日 |○○ |C [10]|2月9日 | | 900|2月9日 | |B [11]|2月8日 | |1330|2月8日 | |B [12]|2月8日 | |1100|2月8日 | |B [13]|2月10日| |1400|2月10日| |C [14]|2月8日 | |1330|2月8日 | |B [15]|2月8日 | |1550|2月8日 | |B [16]|2月9日 |2月10日| |2月9日 | |B [17]|2月1日 |2月28日| |2月1日 | |A ←1日から28日まではこの行のデータが転記したい。 （稲葉） 2019/02/09(土) 12:54 シート2 |[A] |[B] |[C] |[D] |[E] [1] | | |本日の予定| |2月10日 [2] |区分|時刻|予定 |備考 |期間 [3] |A |1200|2月8日 |2月10日出勤|2月9日 ←10日の予定に9日までの予定が入ります。 [4] | | | | | [5] |B | |2月9日 | |2月10日 [6] | | | | | [7] |C | |2月6日 |○○ |不明 [8] | |1400|2月10日 | | [9] | | | | | [10]|D | |1月10日 | |不明 [11]| | |1月28日 | |不明 [12]| | | | | [13]|E | |1月3日 | |不明 [14]| | |1月22日 | |不明 （seiya） 2019/02/09(土) 13:35 このコードでも出来ました。 シート2 |[A] |[B] |[C] |[D] |[E] [1] | | |本日の予定| |2月10日 [2] |区分|時刻|予定 |備考|期間 [3] |A | |2月1日 | |2月28日 [4] | | | | | [5] |B | |2月9日 | |2月10日 [6] | | | | | [7] |C | |2月6日 |○○|不明 [8] | |1400|2月10日 | | [9] | | | | | [10]|D | |1月10日 | |不明 [11]| | |1月28日 | |不明 [12]| | | | | [13]|E | |1月3日 | |不明 [14]| | |1月22日 | |不明 （日報） 2019/02/09(土) 20:06 ---- 並び替えは seiyaさん のをパクッて、、 条件は 隠居じーさん さん のをぱくりました。(￣▽￣;) Meの原型は残ってない(笑) Option Explicit Sub てすと() Dim MyDic As Object Dim MyA As Variant Dim MyB As Variant Dim MyAry As Variant Dim MyDate As Date Dim 項目 As Variant Dim MyKey As String Dim x As Variant Dim y As Variant Dim z As Variant Dim v As Variant Dim i As Long Dim j As Long Dim k As Long Dim MyFlg As Boolean Set MyDic = CreateObject("Scripting.Dictionary") With Sheets("Sheet3") MyA = .Range("A1:E1").Value For j = LBound(MyA, 2) To UBound(MyA, 2) If Not MyDic.Exists(MyA(1, j)) Then Set MyDic(MyA(1, j)) = CreateObject("System.Collections.SortedList") End If Next End With With Sheets("Sheet2") MyDate = .Range("E1").Value End With With Sheets("Sheet1") MyB = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, 6).Value For i = LBound(MyB, 1) To UBound(MyB, 1) If MyB(i, 2) = "不明" Then If MyB(i, 1) < MyDate Then MyFlg = True End If ElseIf MyB(i, 2) = "" Then If MyB(i, 1) = MyDate Then MyFlg = True End If ElseIf TypeName(MyB(i, 2)) = "Date" Then If MyDate >= MyB(i, 1) And MyDate <= MyB(i, 2) Then MyFlg = True End If End If If MyFlg Then If Not MyDic(MyB(i, UBound(MyB, 2))).Contains(Val(MyB(i, 3))) Then k = 1 ReDim v(1 To UBound(MyB, 2) - 1, 1 To k) Else v = MyDic(MyB(i, UBound(MyB, 2)))(Val(MyB(i, 3))) k = UBound(v, 2) ReDim Preserve v(1 To UBound(v, 1), 1 To k + 1) End If For j = 2 To UBound(v, 1) v(j, UBound(v, 2)) = MyB(i, j) Next MyDic(MyB(i, UBound(MyB, 2)))(Val(MyB(i, 3))) = v MyFlg = False End If Next End With k = 1 項目 = Array("区分", "時刻", "予定", "備考", "期間") ReDim MyAry(1 To UBound(項目) + 1, 1 To k) For i = LBound(項目) To UBound(項目) MyAry(i + 1, 1) = 項目(i) Next For Each z In MyDic If MyDic.Exists(z) Then For j = 0 To MyDic(z).Count - 1 x = MyDic(z).GetByIndex(j) For i = LBound(x, 2) To UBound(x, 2) If MyKey <> z Then k = k + 1 ReDim Preserve MyAry(1 To 5, 1 To k) MyAry(1, k) = z MyAry(2, k) = x(3, i) MyAry(3, k) = x(4, i) MyAry(4, k) = x(5, i) MyAry(5, k) = x(2, i) k = k + 1 ReDim Preserve MyAry(1 To 5, 1 To k) MyKey = z Else MyAry(2, k) = x(3, i) MyAry(3, k) = x(4, i) MyAry(4, k) = x(5, i) MyAry(5, k) = x(2, i) k = k + 1 ReDim Preserve MyAry(1 To 5, 1 To k) End If Next Next End If Next With Sheets("Sheet2") v = .Range("C1:E1").Value .Cells.Clear .Range("C1:E1").Value = v .Range("E1").NumberFormat = "m月d日(aaa)" .Range("A2").Resize(UBound(MyAry, 2), UBound(MyAry, 1)).Value = Application.Transpose(MyAry) .Range("E3").Resize(UBound(MyAry, 2) - 1).NumberFormat = "m月d日(aaa)" End With Set MyDic = Nothing Erase MyA, MyB, MyAry, 項目, x, v End Sub （SoulMan） 2019/02/09(土) 20:13 ---- 出来ました!ありがとうございます。 （日報） 2019/02/09(土) 20:30 ---- そうか! 指定日より期間は大きくないとだめなんですね。 '抽出条件 .Range("K1:L4").Value = Application.Evaluate(WorksheetFunction.Substitute("{""日付"",""期間"";""■"","""";""<=■"",""不明"";""<=■"","">=■""}", "■", [Sheet2!E1])) この部分を↑に置き換えて試してみてください。 （稲葉） 2019/02/09(土) 21:17 ---- |[A] |[B] |[C] |[D] |[E] [1] | | |本日の予定| |2月11日(月) [2] |区分|時刻|予定 |備考 |期間 [3] |A |1200|2月8日 |2月10日出勤|2月9日 ←やはりここの部分が転記されてしまいます。 [4] | | | | | [5] |B | |2月9日 | |2月10日 ←ここも転記されます。 [6] | | | | | [7] |C | |2月6日 |○○ |不明 [8] | | | | | [9] |D | |1月10日 | |不明 [10]| | |1月28日 | |不明 [11]| | |2月11日 | |2月20日 [12]| | | | | [13]|E | |1月3日 | |不明 [14]| | |1月22日 | |不明 (SoulMan） 2019/02/09(土) 20:13のコードで作成 |[A] |[B] |[C] |[D] |[E] [1] | | |本日の予定| |2月11日(月) [2] |区分|時刻|予定 |備考|期間 [3] |A | |2月1日 | |2月28日(木) [4] | | | | | [5] |C | |2月6日 |○○|不明 [6] | | | | | [7] |D | |1月10日 | |不明 [8] | | |1月28日 | |不明 [9] | | |2月11日 | |2月20日(水) [10]| | | | | [11]|E | |1月3日 | |不明 [12]| | |1月22日 | |不明 （日報） 2019/02/09(土) 21:51 ---- こんばんは ^^ あれ〜、稲葉さんのコード、修正すれば Seiyaさんのと同じ動きになっていましたですよ。 で すみません、教えていただきたいのですが シート1の抽出元が 5月20日 不明 わ D ↑ 2019/5/20の事(2019/2/8を超えるであれば、いつでもいいのですが） の場合、シート2の本日の予定 E1の値が 2019/2/8 の場合はどうなれば 正解ですか 抽出される 抽出されない 試されましたですか? （隠居じーさん） 2019/02/09(土) 22:09 ---- 新規Bookで試しましたが、隠居じーさん さんの結果と変わりませんよ? 日付 期間 時刻 予定 備考 区分 1月3日 不明 1月3日 E 1月10日 不明 1月10日 D 1月22日 不明 1月22日 E 1月28日 不明 1月28日 D 2月6日 不明 2月6日 ○○ C 2月8日 2月9日 1200 2月8日 2月10日出勤 A 2月11日 2月20日 2月11日 D 2月8日 2月8日 ○○ C 2月9日 900 2月9日 B 2月8日 1330 2月8日 B 2月8日 1100 2月8日 B 2月10日 1400 2月10日 C 2月8日 1330 2月8日 B 2月8日 1550 2月8日 B 2月9日 2月10日 2月9日 B 2月1日 2月28日 2月1日 A ←1日から SoulMan↓ 本日の予定 2月11日(月) 本日の予定 2月11日(月) 区分 時刻 予定 備考 期間 E 2019/1/3 不明 2019/1/22 不明 C 2019/2/6 ○○ 不明 A 2019/2/1 2月28日(木) D 2019/1/10 不明 2019/1/28 不明 2019/2/11 2月20日(水) 隠居じーさん さん↓ 本日の予定 2019/2/11 区分 時刻 予定 備考 期間 E 43468 不明 43487 不明 C 43502 ○○ 不明 A 43497 2月28日 D 43475 不明 43493 不明 43507 2月20日 （SoulMan） 2019/02/09(土) 22:19 ---- あっ、すみません。稲葉さんのコードのことですか? 条件を変えたら同じ結果でしたよ??? > '抽出条件 > .Range("K1:L4").Value = Application.Evaluate(WorksheetFunction.Substitute("{""日付"",""期間"";""■"","""";""<=■"",""不明"";""<=■"","">=■""}", "■", [Sheet2!E1])) 変更されましたか? （SoulMan） 2019/02/09(土) 22:24 ---- 隠居じーさんさん、SoulManさん、急いで確認します。すみません! 隠居じーさんさん。抽出されない、にしたいです。 5月20日から不明が消えるまでの間転記される形にしたいです。 （日報） 2019/02/09(土) 22:31 ---- 出来ました! 稲葉さんすみません! 新しいコードを旧コードの1行上に貼り付け、その後旧コードを削除したんですが、多分新しいコードを削除してました。 SoulManさんのコードで、例えば本日の日付が1/3で、1/3に期限が不明の予定があると転記できないみたいです。 コードを作るって本当に難しいんですね…… （日報） 2019/02/09(土) 22:43 ---- >コードを作るって本当に難しいんですね…… 難しいんじゃなくて条件が不確かなだけですよ? 明確なルールがあれば、みなさんとっくに正解を導かれていますよ。 ルールを作るのも、答えを作るのも、、トピ主さん、、あなしか分からない、知らないんですから、、 少なくとも最初に提示された、 >・シート1の予定からシート2のE1の日付の予定を抽出してシート2に貼り付け。 >・期間にデータが入力されている場合は、その日付が終わるまで抽出対象となる。（2月10日の日報には抽出しない） >・期間が不明の場合は、毎日抽出の対象とする。 >・シート2に転記する際、ABCDEの区分ごと、一つ空白行を入れて次の区分を転記する。（区分は実際にはABCDEではなく、シート3のA1〜E1にプルダウンリスト用として区分を入れています。そのA1〜E1の順番に転記したいです） >・時刻欄にデータがある場合、項目ごとに早い時刻から転記したい。（表示形式は標準の数値です） をベースに話をして頂かないと、、、何が何だかですよ???? （SoulMan） 2019/02/09(土) 22:50 ---- >隠居じーさんさんのコードで出来ました。 なので隠居じーさん さんの条件をお借りしただけで、、、 これを↓ If MyB(i, 2) = "不明" Then If MyB(i, 1) < MyDate Then MyFlg = True End If これにすれば↓でますけどね? If MyB(i, 2) = "不明" Then If MyB(i, 1) <= MyDate Then MyFlg = True End If そうすることで、、他に不都合が出るかもしれません。 要するに条件は、、、どうにでもなる。ということです。 （SoulMan） 2019/02/09(土) 23:07 ---- SoulMan さま、すみません ^^ お世話になりました。。。m(__)m ありがとうございました 。。。 さて、問題も解決されたようですし。 .Cells.Delete を .Cells.ClearContents に変えてみて下さい。 Deleteでもオブジェクトは消えないとは思いますが 位置がずれるなどはあるかもしれませんね。 わたしののは駄作でしたね。私のコードは多分、処理速度も一番遅いと思います 一行でも間に空白行が有っても誤動作するようです。 .Cells.ClearContents に変えていただいても不都合があるなら 配列に変えるか、作業用シートに全てセットして 最後に必要な箇所だけ書込めば回避出来るかもしれませんが。 とりあえずボツで、^^; お願いいたします 列幅が変化するのは下記を 消していただくとおさまると思います。 rr.EntireColumn.AutoFit でわでわ 。。。。。とほほ〜 (#^.^#)〜♪ でも楽しいですね とても勉強させていただきました。 次回に生かしたいと思います。 m(__)m （隠居じーさん） 2019/02/09(土) 23:22 ---- >わたしののは駄作でしたね。私のコードは多分、処理速度も一番遅いと思います そんなことはないと思いますよ 少なくとも私は条件を解読できなかった訳ですから、、、 >明確なルールがあれば、みなさんとっくに正解を導かれていますよ。 って、みなさんを巻き込んじゃいましたけど、、、わかってないのは、、私だけでした(笑) でも、、、期間の考え方が最後まで分かりませんでした。うぅぅぅんんん、、、難しい 精進します。 >。。。。。とほほ〜 (#^.^#)〜♪ でも楽しいですね 楽しかったですね。。。あっという間でしたね。明日もよろしくお願いします。m(__)m PS、日報さんもきつく聞こえたらごめんなさいね。私の読解力が足りないだけでした。m(__)m （SoulMan） 2019/02/09(土) 23:35 ---- 皆様ありがとうございました。 こんなにたくさんのコメントもらえるとは思ってなかったです。 もしまた質問があれば、ルールを明確にして投稿します（本当にごめんなさい m(_ _)m ） コードの中身はちょっと難しいので、しばらくはレイアウトの部分をいじってます。1段下げたりとか、項目を増やして列を挿入とか。 お世話になりました。 （日報） 2019/02/10(日) 00:01 ---- 項目やレイアウト変えると、コード変わります 仕様固まってなかったのですね 1からやり直しかなぁ （稲葉） 2019/02/10(日) 06:35 ---- おはようございます ^^ ＞＞1からやり直しかなぁ w。。。みたいっすね。 稲葉さま、SoulManさま。。。 ありがとうございました。 配列。。。勉強しよう。。。（また三日。。。???かも） (￣▽￣;) m(__)m 日報さん。。。がんばってくださいね。^^ マクロ!べんりですよ。 （隠居じーさん） 2019/02/10(日) 07:17... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201902/20190207200453.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97039 documents and 608037 words.
訪問者：