Results of 1 - 1 of about 37667 for IF (0.007 sec.)
- [[20191130210527]]
- #score: 1591
- @digest: 8ea06b26c1a694834fccce6daf9fd7fb
- @id: 81547
- @mdate: 2019-12-21T10:21:15Z
- @size: 83675
- @type: text/plain
- #keywords: 世帯 (630875), 時枠 (432898), 帯希 (268124), 日枠 (221425), 空枠 (215698), 枠総 (214798), 帯s (214044), 帯総 (204621), 枠tb (193318), 帯区 (179098), 望世 (164962), 望残 (155230), 帯tb (149966), 時db (147616), 理s (146227), extracteddata (139116), 刻s (137176), 望第 (126606), 帯数 (116275), 不叶 (100752), 無回 (98824), 定id (92810), 日時 (73206), 望日 (71661), 総数 (69177), 決定 (60156), 希望 (46598), 数+ (40517), 定日 (35546), 分数 (35334), 数as (31755), 残数 (29255)
- 『希望調査結果の振り分けについて』（kuro）
希望調査結果の振り分けについて。 例えば、工事で1つのマンション30世帯に訪問するとして、時間の希望を取ります。 12/2(月)〜12/7(土)、各曜日9:00、10:00、11:00それぞれ2枠ずつ、 合計で36枠あります。 建前上、第3希望までアンケートを取りますが、極力被らないように、第1希望〜第3希望まで優先度をつけなく割り振りしようと思います。 アンケート回答のなかには、第3希望を書かない人もいたとして、どのような方法がありますでしょうか。 下記のサイトを参考にシートを作成したのですが、上の人から優先順位があるようで、 とくに優先順位は関係なく、できるだけ被りがないようにしたいです。 http://www.excel-excel-excel.com/basic/1268/ もし可能であれば、最終的には時間割表に訪問先を自動で記されるようにしたいです。 識者の皆様、どうかお助けください。 ＜ 使用 Excel:Excel2016、使用 OS:Windows10 ＞ ---- アンケートの集計結果は、エクセルの表に打ち込んであるんでしょうか? あるなら、その表をアップしてください。 (差しさわりある情報は、置き換えてください） （半平太） 2019/11/30(土) 22:22 ---- お世話になります。 https://thuploader.orz.hm/miniup/?mode=dl&id=5806 こちらです。 パスは「1201」です。 実際は12/2(月)〜12/7(土)、各曜日9:00、10:00、11:00それぞれ2枠ずつ、 12/9(月)〜12/14(土)は、各曜日9:00、10:00、11:00それぞれ4枠ずつです。 よろしくお願いいたします。 （kuro） 2019/12/01(日) 17:29 ---- ファイルのアップじゃなくて、エクセルのシートを範囲選択して、コピー。 一旦、メモ帳に貼り付けて、各行頭に半角スペースを挿入後、メモ帳データを再度コピー(※)。 そして、この掲示板に貼り付ける、って方法はとれないでしょうか? ※各行の先頭に半角スペースを入れるのは、形を崩れにくくするため。 （半平太） 2019/12/01(日) 19:26 ---- このような感じです。 部屋番号 第1希望 第2希望 第3希望 101 12/13(金) 09:00 12/11(水) 09:00 12/9(月) 09:00 102 12/16(月) 09:00 12/11(水) 09:00 103 12/14(土) 09:00 12/10(火) 09:00 12/9(月) 09:00 104 12/14(土) 09:00 12/14(土) 10:00 12/14(土) 11:00 105 12/14(土) 09:00 12/21(土) 09:00 106 12/9(月) 09:00 12/10(火) 09:00 12/11(水) 09:00 107 12/18(水) 10:00 12/12(木) 10:00 12/9(月) 10:00 108 109 12/17(火) 09:00 12/20(金) 09:00 12/16(月) 09:00 110 111 201 202 12/20(金) 09:00 12/13(金) 09:00 12/16(月) 09:00 203 204 12/17(火) 09:00 12/19(木) 09:00 12/21(土) 09:00 205 206 12/13(金) 09:00 12/14(土) 09:00 207 12/12(木) 09:00 12/16(月) 09:00 12/19(木) 09:00 208 12/14(土) 11:00 12/21(土) 11:00 209 12/11(水) 10:00 12/12(木) 10:00 12/18(水) 10:00 210 12/9(月) 09:00 12/10(火) 09:00 12/13(金) 09:00 211 12/9(月) 10:00 12/10(火) 10:00 12/16(月) 10:00 301 302 12/11(水) 10:00 12/11(水) 11:00 12/17(火) 10:00 303 12/16(月) 09:00 12/16(月) 10:00 12/16(月) 11:00 304 12/11(水) 09:00 12/10(火) 09:00 12/9(月) 09:00 305 12/9(月) 09:00 12/10(火) 09:00 12/11(水) 09:00 306 12/14(土) 09:00 12/21(土) 09:00 307 308 12/9(月) 09:00 12/16(月) 09:00 309 310 311 12/14(土) 09:00 12/14(土) 10:00 12/21(土) 09:00 401 402 12/17(火) 10:00 403 12/21(土) 11:00 12/21(土) 10:00 12/14(土) 10:00 404 12/13(金) 09:00 12/18(水) 09:00 405 12/14(土) 10:00 12/11(水) 09:00 12/19(木) 09:00 406 12/13(金) 09:00 12/12(木) 09:00 12/9(月) 09:00 407 12/9(月) 09:00 12/9(月) 10:00 12/9(月) 11:00 408 409 12/9(月) 09:00 12/11(水) 09:00 12/12(木) 09:00 410 12/9(月) 11:00 12/11(水) 11:00 12/16(月) 11:00 411 12/10(火) 09:00 12/11(水) 09:00 12/12(木) 09:00 501 12/11(水) 11:00 12/13(金) 11:00 12/17(火) 11:00 502 503 12/9(月) 09:00 12/14(土) 09:00 504 12/19(木) 09:00 12/20(金) 09:00 12/21(土) 09:00 505 12/9(月) 09:00 12/9(月) 10:00 12/9(月) 11:00 506 12/9(月) 09:00 12/9(月) 10:00 12/9(月) 11:00 （kuro） 2019/12/02(月) 17:29 ---- 1.タイトルとセルのアドレスを加味すると、下図の様になっていると考えていいですか? <レイアウト確認用> 行 ____A____ ____B____ __C__ ____D____ _ E _ ___ F ___ __G__ 1 部屋番号 第1希望 第2希望 第3希望 2 101 12/13(金) 9:00 12/11(水) 9:00 12/9(月) 9:00 3 102 12/16(月) 9:00 12/11(水) 9:00 4 103 12/14(土) 9:00 12/10(火) 9:00 12/9(月) 9:00 5 104 12/14(土) 9:00 12/14(土) 10:00 12/14(土) 11:00 6 : : : : 2.B,D,F列にある日付データに曜日が書かれていますが、実体は日付シリアル値であって、 「セルの書式」を設定して、そう見えるようにしているんですね? （半平太） 2019/12/02(月) 21:09 ---- <レイアウト確認用> 行 ____A____ ________B_______ ________C_______ ________D_______ 1 部屋番号 第1希望 第2希望 第3希望 2 101 12/13(金) 9:00 12/11(水) 9:00 12/9(月) 9:00 3 102 12/16(月) 9:00 12/11(水) 9:00 4 103 12/14(土) 9:00 12/10(火) 9:00 12/9(月) 9:00 5 104 12/14(土) 9:00 12/14(土) 10:00 12/14(土) 11:00 6 : : : : このように表記しておりました。 B,C,Dの希望のセルは、F列の値をドロップダウンリストで表示しております。 例えば、F1には『=TEXT(G1, "m/d(aaa)")&TEXT(H1, " hh:mm")』と入力し、 G列、H列の値を合わせて表示しておりました。 行 ________F______ ________G______ ________H_______ 1 日時 日付 開始時間 2 12/9(月) 09:00 12/9(月) 9:00 3 12/9(月) 10:00 12/10(火) 10:00 4 12/9(月) 11:00 12/11(水) 11:00 : : 12 12/12(木) 11:00 12/21(土) : 36 12/21(土) 11:00 もっとこうしたほうがいいなどあれば、別のやり方でも構いません。 よろしくお願いいたします。 （kuro） 2019/12/03(火) 11:04 ---- Sub main() Dim sht1 As Worksheet, sht2 As Worksheet, c As Range, cc As Range, r As Range, i As Long, x As Long Set sht1 = Sheets("Sheet1") 'データ元のシートを指定 Set sht2 = Sheets("Sheet2") '時間割表シートを指定 sht2.Cells.ClearContents For Each c In sht1.Range("G:G").SpecialCells(2) For Each cc In sht1.Range("H:H").SpecialCells(2) x = 0 If Day(c.Value) <= 7 Then x = 2 If Day(c.Value) >= 9 Then x = 4 If x > 0 Then For i = 1 To x sht2.Range("A" & Rows.Count).End(xlUp).Offset(1).Value = _ WorksheetFunction.Text(c.Value, "m/d(aaa)") & WorksheetFunction.Text(cc.Value, " hh:mm") Next i End If Next cc Next c Set r = sht1.Range("A2") Do If r.Value = "" Then Exit Do If WorksheetFunction.CountA(r.Offset(, 1).Resize(, 3)) > 0 Then For Each c In r.Offset(, 1).Resize(, 3).SpecialCells(2) Set rr = sht2.Range("A2") Do If rr.Value = "" Then Exit Do If c.Value = rr.Value And rr.Offset(, 1).Value = "" Then rr.Offset(, 1).Value = r.Value: Exit For Else Set rr = rr.Offset(1) End If Loop Next c End If Set r = r.Offset(1) Loop End Sub （mm） 2019/12/03(火) 16:13 ---- ＞もっとこうしたほうがいいなどあれば、別のやり方でも構いません。 うーん、加工後のデータは、再利用しにくいんですよね。 当方は、こちらの方を想定していたのですけども。。 ↓ 行 ____A____ ____B____ __C__ ____D____ _ E _ ___ F ___ __G__ 1 部屋番号 第1希望 第2希望 第3希望 2 101 12/13(金) 9:00 12/11(水) 9:00 12/9(月) 9:00 3 102 12/16(月) 9:00 12/11(水) 9:00 それだと、B,D,C列の実体値は日付シリアル値で(通常、2109/11/30の様になっている値）、 セルの書式をユーザー設定で → m/d(aaa) hh:mm;@ として、上図の様に見せかける。 ※シリアル値は、年情報を含んでいるので扱い易い。 もし、アンケート結果を上の様な形に出来るなら、 枠数の指定を下図の様に指定する。(これは手作業) 行 ___ J ___ __K__ _ L _ __M__ 1 日時枠 9:00 10:00 11:00 2 12/9(月) 2 2 2 3 12/10(火) 2 2 2 4 12/11(水) 2 2 2 5 12/12(木) 2 2 2 6 12/13(金) 2 2 2 7 12/14(土) 2 2 2 8 12/16(月) 4 4 4 9 12/17(火) 4 4 4 10 12/18(水) 4 4 4 11 12/19(木) 4 4 4 12 12/20(金) 4 4 4 13 12/21(土) 4 4 4 枠数の指定ができたら、後記マクロ(Main)を実行する。 すると、自動的に下図の振分けが終了する。 <結果図> 行 ___A___ ___B___ __C__ ___D___ _ E _ __ F __ __G__ _____H_____ ___ I ___ ___ J ___ __K__ _ L _ __M__ _N_ ___ O ___ _____ P _____ _____ Q _____ __R__ 1 世帯idx 第1希望 第2希望 第3希望 決定 希望順位 日時枠 9:00 10:00 11:00 日時枠 9:00 10:00 11:00 2 101 12/13 9:00 12/11 9:00 12/9 9:00 12/13 09:00 1 12/9(月) 2 2 2 12/9(月) 106号 407号、506号 505号 3 102 12/16 9:00 12/11 9:00 12/16 09:00 1 12/10(火) 2 2 2 12/10(火) 103号、210号 211号 4 103 12/14 9:00 12/10 9:00 12/9 9:00 12/10 09:00 2 12/11(水) 2 2 2 12/11(水) 304号、305号 209号 302号 5 104 12/14 9:00 12/14 10:00 12/14 11:00 12/14 11:00 3 12/12(木) 2 2 2 12/12(木) 409号、411号 6 105 12/14 9:00 12/21 9:00 12/21 09:00 2 12/13(金) 2 2 2 12/13(金) 101号、406号 501号 7 106 12/9 9:00 12/10 9:00 12/11 9:00 12/9 09:00 1 12/14(土) 2 2 2 12/14(土) 206号、503号 311号、405号 104号 8 107 12/18 10:00 12/12 10:00 12/9 10:00 12/18 10:00 1 12/16(月) 4 4 4 12/16(月) 102号、308号 303号 410号 9 108 無回答 12/17(火) 4 4 4 12/17(火) 109号、204号 402号 10 109 12/17 9:00 12/20 9:00 12/16 9:00 12/17 09:00 1 12/18(水) 4 4 4 12/18(水) 404号 107号 11 110 無回答 12/19(木) 4 4 4 12/19(木) 207号 12 111 無回答 12/20(金) 4 4 4 12/20(金) 202号、504号 13 201 無回答 12/21(土) 4 4 4 12/21(土) 105号、306号 403号 208号 ※マクロのコピペ先は、当該シートの「シートモジュール」に行ってください。 ↑ (重要:すなわち標準モジュールではない） 'コピペするマクロ----ここから、最下行まで Const 時間帯区分数 As Long = 6 '予想される最大区分数(実データがそれより少なくても構わない） Const 希望可能数 As Long = 6 '予想される最大希望数(実データがそれより少なくても構わない Private Type 希望 日付 As Date 時刻 As Date End Type Private Type 世帯 Idx As Long 部屋番号 As Variant 希望s(1 To 希望可能数) As 希望 希望日時DBL(1 To 希望可能数) As Double 希望残数 As Long 決定日時 As Variant 乱数 As Long End Type Private Type 時刻 軒目s() As Long '一つの時間帯に何世帯可能か End Type Private Type 日時枠 日付 As Double 'DateSerial 時刻s(1 To 時間帯区分数) As 時刻 '時間帯区分数 End Type Private Type 管理 決定世帯数 As Long 不可能世帯数 As Long 未決定日時総数 As Long 無回答世帯数 As Long End Type Private 日時枠s() As 日時枠 Private 世帯s() As 世帯 Private 管理s() As 管理 Private 日枠総数 As Long Private 世帯総数 As Long Private 時間区分TBL Private 日時枠TBL Private 結果TBL() Sub Main() Dim 決定Idx As Long Dim NN As Long, KK As Long, LL As Long Dim Rw As Long, CL As Long Dim dic世帯希望 As Object Dim dic空枠 As Object Dim ExtractedData Dim topNum, endRw As Long Dim firstPos Dim numToAssign Dim numtoAssignSpltd Dim MinStr As String, OrderingStr As String Dim 決定日, 決定時刻 Dim exhausted As Boolean Dim loopCnt As Long Application.ScreenUpdating = False Randomize ReDim 管理s(1 To 1) 時間区分TBL = Range("K1").Resize(1, 時間帯区分数).Value 世帯総数 = Cells(Rows.Count, 1).End(xlUp).Row - 1 Call 世帯情報格納 '基本情報格納(世帯) Call 日時枠情報格納 '基本情報格納(日時枠) Set dic世帯希望 = CreateObject("Scripting.Dictionary") Set dic空枠 = CreateObject("Scripting.Dictionary") '振分けルーチン--------------------------------- Do Until exhausted Or loopCnt > 世帯総数 + 1 loopCnt = loopCnt + 1 '無限ループ防止 Call 全世帯洗い出し(dic世帯希望) If dic世帯希望.Count > 0 Then Rem 空日時枠を洗い出す Call 空日時枠洗い出し(dic空枠) If dic空枠.Count > 0 Then Rem 調査結果を表示する Call 調査結果表示(dic空枠, dic世帯希望) Rem 割当作業開始(希望数が有って、その該当数もある場合)------------ If Application.Sum(Columns("AC")) > 0 Then Rem (1) 実現不可能な希望をつぶす ExtractedData = Range("AA2").Resize(dic世帯希望.Count, 3).Value For Rw = 1 To UBound(ExtractedData) If ExtractedData(Rw, 3) = 0 Then Call 不叶希望排除(ExtractedData(Rw, 1), 世帯s, 管理s(1)) End If Next Rem (2) 抽出範囲内に於ける該当初行を求める firstPos = Me.Evaluate("MATCH(0,0/(AC2:AC" & (dic世帯希望.Count + 2) & ">0),0)") '1行水増し topNum = ExtractedData(firstPos, 2) '該当初行の希望数をメモする For Rw = firstPos To UBound(ExtractedData) '0超で最少の希望数同士だけピックアップ If topNum <> ExtractedData(Rw, 2) Then '最少希望数が異なる endRw = Rw - 1 Exit For End If Next If Rw > UBound(ExtractedData) Then endRw = Rw - 1 End If Rem 割当を一つに絞る MinStr = "A" '仮決め For NN = firstPos To endRw For KK = 1 To 世帯総数 OrderingStr = get希望世帯(ExtractedData(NN, 1), 世帯s(KK)) If OrderingStr <> "" Then If OrderingStr < MinStr Then MinStr = OrderingStr End If End If Next KK Next NN numtoAssignSpltd = Split(MinStr, "-") 決定Idx = CLng(numtoAssignSpltd(3)) '割振りが決定 '確定世帯を消込む 世帯s(決定Idx).決定日時 = CDbl(numtoAssignSpltd(4)) 世帯s(決定Idx).希望残数 = 0 管理s(1).決定世帯数 = 管理s(1).決定世帯数 + 1 決定日 = CDate(Format(Left(世帯s(決定Idx).決定日時, 8), "0000/00/00")) 決定時刻 = CDate(Format(Right(世帯s(決定Idx).決定日時, 4), "00:00")) '日時枠を消込む Call 日時枠消込み(決定Idx, 決定日, 決定時刻) Else exhausted = True End If End If Else exhausted = True End If numToAssign = Empty '初期化 dic世帯希望.RemoveAll dic空枠.RemoveAll Loop '-------------------------------------------------------- Call showResult '結果打ち出し Application.ScreenUpdating = True MsgBox "決定数:" & 管理s(1).決定世帯数 & vbLf & _ "不叶数:" & Application.CountIf(Columns("H"), "不叶") End Sub Private Sub 世帯情報格納() Dim 世帯TBL Dim Idx As Long, CL As Long Range("I1").Value = "乱数" Range("I2").Resize(世帯総数, 1).Value = getShuffuledOrder(世帯総数) 世帯TBL = Range("A2").Resize(世帯総数, 9).Value ReDim 世帯s(1 To 世帯総数) For Idx = 1 To 世帯総数 With 世帯s(Idx) .Idx = Idx .部屋番号 = 世帯TBL(Idx, 1) .乱数 = 世帯TBL(Idx, 9) For CL = 1 To 希望可能数 If 世帯TBL(Idx, CL + 1) <> "" Then .希望s(CL).日付 = CDate(Replace(Split(世帯TBL(Idx, CL + 1), "(")(0), " ", "")) .希望s(CL).時刻 = CDate(Replace(Split(世帯TBL(Idx, CL + 1), ")")(1), " ", "")) .希望日時DBL(CL) = CDbl(Format(.希望s(CL).日付 + .希望s(CL).時刻, "yyyymmddhhnn")) .希望残数 = .希望残数 + 1 Else .希望日時DBL(CL) = 0 End If Next CL If .希望残数 = 0 Then 管理s(1).無回答世帯数 = 管理s(1).無回答世帯数 + 1 End If End With Next Idx 管理s(1).不可能世帯数 = 管理s(1).無回答世帯数 End Sub Private Sub 日時枠情報格納() Dim Idx As Long, CL As Long 日枠総数 = Cells(1, "J").End(xlDown).Row - 1 日時枠TBL = Range("J1").Resize(日枠総数 + 1, 時間帯区分数 + 1).Value ReDim 結果TBL(2 To 日枠総数 + 1, 2 To 時間帯区分数 + 1) '結果表示用 ReDim 日時枠s(1 To 日枠総数) For Idx = 1 To 日枠総数 With 日時枠s(Idx) .日付 = 日時枠TBL(Idx + 1, 1) For CL = 1 To 時間帯区分数 If 日時枠TBL(Idx + 1, CL + 1) > 0 Then ReDim .時刻s(CL).軒目s(1 To 日時枠TBL(Idx + 1, CL + 1)) 管理s(1).未決定日時総数 = 管理s(1).未決定日時総数 + 日時枠TBL(Idx + 1, CL + 1) Else ReDim .時刻s(CL).軒目s(0 To 0) ' Stop End If Next CL End With Next Idx End Sub Private Function get希望世帯(ByVal ck, ByRef 世帯 As 世帯) As String Dim NN As Long, Prio With 世帯 If IsEmpty(.決定日時) Then '決まってなければ For NN = 1 To 希望可能数 '全部見る If .希望日時DBL(NN) > 0 Then Prio = .希望日時DBL(NN) If Prio = ck Then get希望世帯 = Format(.希望残数, "00-") get希望世帯 = get希望世帯 & Format(NN, "00-") '優先順位 get希望世帯 = get希望世帯 & Format(.乱数, "000-") get希望世帯 = get希望世帯 & Format(世帯.Idx, "000-") '世帯NO get希望世帯 = get希望世帯 & ck Exit For End If End If Next End If End With End Function Private Sub showResult() '結果打ち出し Dim Idx As Long, Rw As Long, CL As Long, Done As Boolean Dim 決定日, 決定時刻 Range("J1").Offset(日枠総数 + 2, 0).Resize(500, 15).ClearContents Range("J1").Offset(日枠総数 + 2).Resize(日枠総数 + 1, 時間帯区分数 + 1).Value = 日時枠TBL With Range("H2").Resize(世帯総数, 1) .Formula = "=IF(COUNTA(B2:G2)=0,""無回答"",""不叶"")" .Value = .Value End With For Idx = 1 To 世帯総数 With 世帯s(Idx) If Not IsEmpty(.決定日時) Then 決定日 = CDate(Format(Left(.決定日時, 8), "0000/00/00")) 決定時刻 = CDate(Format(Right(.決定日時, 4), "00:00")) Done = False For Rw = 2 To UBound(日時枠TBL) If 日時枠TBL(Rw, 1) = 決定日 Then For CL = 2 To UBound(日時枠TBL, 2) If 日時枠TBL(1, CL) = 決定時刻 Then 結果TBL(Rw, CL) = 結果TBL(Rw, CL) & " " & .部屋番号 & "号" Cells(Idx + 1, 8).Value = 決定日 + 決定時刻 Done = True Exit For End If Next CL If Done Then Exit For End If End If Next End If End With Next Idx With Range("J1").Offset(日枠総数 + 3, 1).Resize(日枠総数, 時間帯区分数) .Value = 結果TBL .Value = Me.Evaluate("INDEX(SUBSTITUTE(TRIM(" & .Address & "),"" "",""、""),0,0)") End With Range("I1").Value = "希望順位" With Range("I2").Resize(世帯総数, 1) .Formula = "=IF(OR(H2={""無回答"",""不叶""}),"""",MATCH(TEXT(H2,""yyyy/m/d(aaa) h:mm""),B2:G2,0))" End With Columns("J").Resize(, 時間帯区分数 + 1).AutoFit End Sub Private Sub 全世帯洗い出し(ByRef dic世帯希望 As Object) '全世帯の希望時間帯を洗い出す Dim Idx As Long, NN As Long, Prio As Double For Idx = 1 To 世帯総数 With 世帯s(Idx) If IsEmpty(.決定日時) And .希望残数 > 0 Then '未決定且つ希望残あり For NN = 1 To 希望可能数 '全部見る If .希望日時DBL(NN) > 0 Then Prio = .希望日時DBL(NN) dic世帯希望(Prio) = dic世帯希望(Prio) + 1 End If Next End If End With Next Idx End Sub Private Sub 空日時枠洗い出し(ByRef dic空枠 As Object) Dim Idx As Long, NN As Long, KK As Long, Prio As Double For Idx = 1 To 日枠総数 With 日時枠s(Idx) For NN = 1 To UBound(.時刻s) Prio = CDbl(Format(.日付 + 時間区分TBL(1, NN), "yyyymmddhhnn")) For KK = 1 To UBound(.時刻s(NN).軒目s) If .時刻s(NN).軒目s(KK) = 0 Then '世帯Noが無ければ dic空枠(Prio) = dic空枠(Prio) + 1 End If Next KK Next End With Next Idx End Sub Private Sub 不叶希望排除(ByVal ck, ByRef 世帯s() As 世帯, ByRef 管理 As 管理) Dim Idx As Long, NN As Long, Prio For Idx = 1 To UBound(世帯s) With 世帯s(Idx) If IsEmpty(.決定日時) Then '決まってなければ For NN = 1 To 希望可能数 '全部見る If .希望日時DBL(NN) > 0 Then Prio = .希望日時DBL(NN) If Prio = ck Then .希望日時DBL(NN) = 0 .希望残数 = .希望残数 - 1 If .希望残数 = 0 Then 管理.不可能世帯数 = 管理.不可能世帯数 + 1 End If Exit For End If End If Next End If End With Next Idx End Sub Private Sub 調査結果表示(ByRef dic空枠 As Object, dic世帯希望 As Object) Dim Rslt空枠, Rslt世帯希望 Rslt空枠 = dic空枠.items Columns("AA:AJ").ClearContents Range("AD2").Resize(dic空枠.Count, 2).Value = Application.Transpose(Array(dic空枠.keys, Rslt空枠)) Rslt世帯希望 = dic世帯希望.items With Range("AA2").Resize(dic世帯希望.Count, 2) .Value = Application.Transpose(Array(dic世帯希望.keys, Rslt世帯希望)) With .Resize(, 1).Offset(, 2) .Formula = "=SUMIF(AD:AD,AA2,AE:AE)" .Value = .Value End With End With 'タイトル記入 Range("AA1:AE1").Value = Array("希望日時", "希望数", "該当数", "空枠日時", "空枠数") '希望数で並べ替え 並べ替え Range("AA1").Resize(dic世帯希望.Count + 1, 3) '1行目から End Sub Private Sub 日時枠消込み(ByVal 決定Idx, ByVal 決定日, ByVal 決定時刻) Dim NN As Long, KK As Long, LL As Long For NN = 1 To 日枠総数 With 日時枠s(NN) If .日付 = 決定日 Then For KK = 1 To 時間帯区分数 If 時間区分TBL(1, KK) = 決定時刻 Then For LL = 1 To UBound(.時刻s(KK).軒目s) If .時刻s(KK).軒目s(LL) = 0 Then .時刻s(KK).軒目s(LL) = 決定Idx Exit Sub End If Next LL End If Next KK End If End With Next NN End Sub Private Function getShuffuledOrder(ByVal lastNum As Long) Dim NN As Long Dim 乱数rand() Dim Order() ReDim 乱数(1 To lastNum) ReDim Order(1 To lastNum) For NN = 1 To lastNum 乱数(NN) = Rnd Order(NN) = NN Next NN With Application getShuffuledOrder = .Transpose(.Match(.Small(乱数, Order), 乱数, 0)) End With End Function Private Sub 並べ替え(ByRef rToSort As Range) '並べ替え Me.Sort.SortFields.Clear Me.Sort.SortFields.Add Key:=Range("AB2"), SortOn:=xlSortOnValues, Order:=xlAscending With Me.Sort .SetRange rToSort .Header = xlYes .Orientation = xlTopToBottom .Apply End With End Sub 'ここまで （半平太） 2019/12/03(火) 16:49 → 全面上書き修正 2019/12/21(土) 19:19 ---- 書き忘れ・・ J列の日付もシリアル値でお願いします。 （半平太） 2019/12/03(火) 16:51 ---- お世話になります。 希望にそえない場合はどのような表示になるのでしょうか。 また、今後、別件でもこのデータの利用を考えているのですが、 世帯数、希望数（第1希望〜第5希望に増やす）、期間等を変更しても 問題なく利用できるのでしょうか。 もし、利用できない場合は、変更する箇所など教えていただければ幸いです。 （kuro） 2019/12/03(火) 17:20 ---- まずは、mmさんのが簡単に処理できているようなので、そちらを当たってください。 ＞希望にそえない場合はどのような表示になるのでしょうか。 ちょっと意味が分からないです。前提が違うのでプログラムはトラブるだけです。 ＞世帯数、希望数（第1希望〜第5希望に増やす）、期間等を変更しても 世帯数は何も問題ないですが、 列数が想定外に多くなるので、1希望につき1列で処理するように改変せざるを得ません。 データは、今そちらにあるデータのような形式になりそう。 現在は、年情報が無いですが(無いままでもできないわけではないですが）、あった方が安全。 数式としてはこう変えるだけですから、ちょっとの手間を惜しんで ストレスを溜める事もないと思いますけどね。 ↓ =TEXT(G1, "yyyy/m/d(aaa)")&TEXT(H1," hh:mm") （半平太） 2019/12/03(火) 19:13 ---- 半平太 様 希望にそえない場合は〜というのは、第1〜第3に当てはまらない場合の表記のことでした。 説明不足で申し訳ございません。 また、H、I列に第4希望、J、K列に第5希望の項目を付け足してみて、マクロのモジュールを編集してみたのですが、実行すると、「H列の2行目以下に日付+時間」が出力され、「L列には不叶、無回答」が出力され、うまくいきません。 どこがおかしいかご指摘いただけますと幸いです。 Const 時間帯区分数 As Long = 3 Const 希望可能数 As Long = 3 Private Type 希望 日付 As Date 時刻 As Date End Type Private Type 世帯 Idx As Long 部屋番号 As Variant 希望s(1 To 希望可能数) As 希望 希望日時DBL(1 To 希望可能数) As Double 希望残数 As Long 決定日時 As Variant 乱数 As Long End Type Private Type 時刻 軒目s() As Long '一つの時間帯に何世帯可能か End Type Private Type 日時枠 日付 As Double 'DateSerial 時刻s(1 To 時間帯区分数) As 時刻 '時間帯区分数 End Type Private Type 管理 決定世帯数 As Long 不可能世帯数 As Long 未決定日時総数 As Long 無回答世帯数 As Long End Type Private 日時枠s() As 日時枠 Private 世帯s() As 世帯 Private 管理s() As 管理 Private 日枠総数 As Long Private 世帯総数 As Long Private 時間区分TBL Private 日時枠TBL Private 結果TBL() Sub Main() Dim 決定Idx As Long Dim NN As Long, KK As Long, LL As Long Dim Rw As Long, CL As Long Dim dic世帯希望 As Object Dim dic空枠 As Object Dim ExtractedData Dim topNum, endRw As Long Dim firstPos Dim numToAssign Dim numtoAssignSpltd Dim MinStr As String, OrderingStr As String Dim 決定日, 決定時刻 Dim exhausted As Boolean Dim loopCnt As Long Application.ScreenUpdating = False Randomize ReDim 管理s(1 To 1) 時間区分TBL = Range("O1").Resize(1, 時間帯区分数).Value 世帯総数 = Cells(Rows.Count, 1).End(xlUp).Row - 1 Call 世帯情報格納 '基本情報格納(世帯) Call 日時枠情報格納 '基本情報格納(日時枠) Set dic世帯希望 = CreateObject("Scripting.Dictionary") Set dic空枠 = CreateObject("Scripting.Dictionary") '振分けルーチン--------------------------------- Do Until exhausted Or loopCnt > 世帯総数 + 1 loopCnt = loopCnt + 1 '無限ループ防止 Call 全世帯洗い出し(dic世帯希望) If dic世帯希望.Count > 0 Then Rem 空日時枠を洗い出す Call 空日時枠洗い出し(dic空枠) If dic空枠.Count > 0 Then Rem 調査結果を表示する Call 調査結果表示(dic空枠, dic世帯希望) Rem 割当作業開始(希望数が有って、その該当数もある場合)------------ If Application.Sum(Columns("AG")) > 0 Then Rem (1) 実現不可能な希望をつぶす ExtractedData = Range("AE2").Resize(dic世帯希望.Count, 3).Value For Rw = 1 To UBound(ExtractedData) If ExtractedData(Rw, 3) = 0 Then Call 不叶希望排除(ExtractedData(Rw, 1), 世帯s, 管理s(1)) End If Next Rem (2) 抽出範囲内に於ける該当初行を求める firstPos = Me.Evaluate("MATCH(0,0/(AG2:AG" & (dic世帯希望.Count + 2) & ">0),0)") '1行水増し topNum = ExtractedData(firstPos, 2) '該当初行の希望数をメモする For Rw = firstPos To UBound(ExtractedData) '0超で最少の希望数同士だけピックアップ If topNum <> ExtractedData(Rw, 2) Then '最少希望数が異なる endRw = Rw - 1 Exit For End If Next If Rw > UBound(ExtractedData) Then endRw = Rw - 1 End If Rem 割当を一つに絞る MinStr = "A" '仮決め For NN = firstPos To endRw For KK = 1 To 世帯総数 OrderingStr = get希望世帯(ExtractedData(NN, 1), 世帯s(KK)) If OrderingStr <> "" Then If OrderingStr < MinStr Then MinStr = OrderingStr End If End If Next KK Next NN numtoAssignSpltd = Split(MinStr, "-") 決定Idx = CLng(numtoAssignSpltd(3)) '割振りが決定 '確定世帯を消込む 世帯s(決定Idx).決定日時 = CDbl(numtoAssignSpltd(4)) 世帯s(決定Idx).希望残数 = 0 管理s(1).決定世帯数 = 管理s(1).決定世帯数 + 1 決定日 = CDate(Format(Left(世帯s(決定Idx).決定日時, 8), "0000/00/00")) 決定時刻 = CDate(Format(Right(世帯s(決定Idx).決定日時, 4), "00:00")) '日時枠を消込む Call 日時枠消込み(決定Idx, 決定日, 決定時刻) Else exhausted = True End If End If Else exhausted = True End If numToAssign = Empty '初期化 dic世帯希望.RemoveAll dic空枠.RemoveAll Loop '-------------------------------------------------------- Call showResult '結果打ち出し Application.ScreenUpdating = True MsgBox "決定数:" & 管理s(1).決定世帯数 & vbLf & _ "不叶数:" & Application.CountIf(Columns("L"), "不叶") End Sub Private Sub 世帯情報格納() Dim 世帯TBL Dim Idx As Long, CL As Long Range("M1").Value = "乱数" Range("M2").Resize(世帯総数, 1).Value = getShuffuledOrder(世帯総数) 世帯TBL = Range("A2").Resize(世帯総数, 9).Value ReDim 世帯s(1 To 世帯総数) For Idx = 1 To 世帯総数 With 世帯s(Idx) .Idx = Idx .部屋番号 = 世帯TBL(Idx, 1) .乱数 = 世帯TBL(Idx, 9) For CL = 1 To 希望可能数 If 世帯TBL(Idx, CL * 2) <> "" Then .希望s(CL).日付 = 世帯TBL(Idx, CL * 2) .希望s(CL).時刻 = 世帯TBL(Idx, CL * 2 + 1) .希望日時DBL(CL) = CDbl(Format(.希望s(CL).日付 + .希望s(CL).時刻, "yyyymmddhhnn")) .希望残数 = .希望残数 + 1 Else .希望日時DBL(CL) = 0 End If Next CL If .希望残数 = 0 Then 管理s(1).無回答世帯数 = 管理s(1).無回答世帯数 + 1 End If End With Next Idx 管理s(1).不可能世帯数 = 管理s(1).無回答世帯数 End Sub Private Sub 日時枠情報格納() Dim Idx As Long, CL As Long 日枠総数 = Cells(Rows.Count, "N").End(xlUp).Row - 1 日時枠TBL = Range("N1").Resize(日枠総数 + 1, 時間帯区分数 + 1).Value ReDim 結果TBL(2 To 日枠総数 + 1, 2 To 時間帯区分数 + 1) '結果表示用 ReDim 日時枠s(1 To 日枠総数) For Idx = 1 To 日枠総数 With 日時枠s(Idx) .日付 = 日時枠TBL(Idx + 1, 1) For CL = 1 To 時間帯区分数 If 日時枠TBL(Idx + 1, CL + 1) > 0 Then ReDim .時刻s(CL).軒目s(1 To 日時枠TBL(Idx + 1, CL + 1)) 管理s(1).未決定日時総数 = 管理s(1).未決定日時総数 + 日時枠TBL(Idx + 1, CL + 1) Else Stop End If Next CL End With Next Idx End Sub Private Function get希望世帯(ByVal ck, ByRef 世帯 As 世帯) As String Dim NN As Long, Prio With 世帯 If IsEmpty(.決定日時) Then '決まってなければ For NN = 1 To 希望可能数 '全部見る If .希望日時DBL(NN) > 0 Then Prio = .希望日時DBL(NN) If Prio = ck Then get希望世帯 = Format(.希望残数, "00-") get希望世帯 = get希望世帯 & Format(NN, "00-") '優先順位 get希望世帯 = get希望世帯 & Format(.乱数, "000-") get希望世帯 = get希望世帯 & Format(世帯.Idx, "000-") '世帯NO get希望世帯 = get希望世帯 & ck Exit For End If End If Next End If End With End Function Private Sub showResult() '結果打ち出し Dim Idx As Long, Rw As Long, CL As Long, Done As Boolean Dim 決定日, 決定時刻 Range("S1").Resize(日枠総数 + 1, 時間帯区分数 + 1).Value = 日時枠TBL With Range("L2").Resize(世帯総数, 1) .Formula = "=IF(COUNT(B2:D2)=0,""無回答"",""不叶"")" .Value = .Value End With For Idx = 1 To 世帯総数 With 世帯s(Idx) If Not IsEmpty(.決定日時) Then 決定日 = CDate(Format(Left(.決定日時, 8), "0000/00/00")) 決定時刻 = CDate(Format(Right(.決定日時, 4), "00:00")) Done = False For Rw = 2 To UBound(日時枠TBL) If 日時枠TBL(Rw, 1) = 決定日 Then For CL = 2 To UBound(日時枠TBL, 2) If 日時枠TBL(1, CL) = 決定時刻 Then 結果TBL(Rw, CL) = 結果TBL(Rw, CL) & " " & .部屋番号 & "号" Cells(Idx + 1, 8).Value = 決定日 + 決定時刻 Done = True Exit For End If Next CL If Done Then Exit For End If End If Next End If End With Next Idx With Range("T2").Resize(日枠総数, 時間帯区分数) .Value = 結果TBL .Value = Me.Evaluate("INDEX(SUBSTITUTE(TRIM(" & .Address & "),"" "",""、""),0,0)") End With Range("M1").Value = "希望順位" With Range("M2").Resize(世帯総数, 1) .Formula = "=IF(OR(L2={""無回答"",""不叶""}),"""",(MATCH(L2,INDEX((B2:J2+C2:K2)*ISEVEN(COLUMN(B2:J2)),0),0)+1)/2)" End With Columns("O").Resize(, 時間帯区分数 + 1).AutoFit End Sub Private Sub 全世帯洗い出し(ByRef dic世帯希望 As Object) '全世帯の希望時間帯を洗い出す Dim Idx As Long, NN As Long, Prio As Double For Idx = 1 To 世帯総数 With 世帯s(Idx) If IsEmpty(.決定日時) And .希望残数 > 0 Then '未決定且つ希望残あり For NN = 1 To 希望可能数 '全部見る If .希望日時DBL(NN) > 0 Then Prio = .希望日時DBL(NN) dic世帯希望(Prio) = dic世帯希望(Prio) + 1 End If Next End If End With Next Idx End Sub Private Sub 空日時枠洗い出し(ByRef dic空枠 As Object) Dim Idx As Long, NN As Long, KK As Long, Prio As Double For Idx = 1 To 日枠総数 With 日時枠s(Idx) For NN = 1 To UBound(.時刻s) Prio = CDbl(Format(.日付 + 時間区分TBL(1, NN), "yyyymmddhhnn")) For KK = 1 To UBound(.時刻s(NN).軒目s) If .時刻s(NN).軒目s(KK) = 0 Then '世帯Noが無ければ dic空枠(Prio) = dic空枠(Prio) + 1 End If Next KK Next End With Next Idx End Sub Private Sub 不叶希望排除(ByVal ck, ByRef 世帯s() As 世帯, ByRef 管理 As 管理) Dim Idx As Long, NN As Long, Prio For Idx = 1 To UBound(世帯s) With 世帯s(Idx) If IsEmpty(.決定日時) Then '決まってなければ For NN = 1 To 希望可能数 '全部見る If .希望日時DBL(NN) > 0 Then Prio = .希望日時DBL(NN) If Prio = ck Then .希望日時DBL(NN) = 0 .希望残数 = .希望残数 - 1 If .希望残数 = 0 Then 管理.不可能世帯数 = 管理.不可能世帯数 + 1 End If Exit For End If End If Next End If End With Next Idx End Sub Private Sub 調査結果表示(ByRef dic空枠 As Object, dic世帯希望 As Object) Dim Rslt空枠, Rslt世帯希望 Rslt空枠 = dic空枠.items Columns("AA:AN").ClearContents Range("AH2").Resize(dic空枠.Count, 2).Value = Application.Transpose(Array(dic空枠.keys, Rslt空枠)) Rslt世帯希望 = dic世帯希望.items With Range("AE2").Resize(dic世帯希望.Count, 2) .Value = Application.Transpose(Array(dic世帯希望.keys, Rslt世帯希望)) With .Resize(, 1).Offset(, 2) .Formula = "=SUMIF(AH:AH,AE2,AI:AI)" .Value = .Value End With End With 'タイトル記入 Range("AE1:AI1").Value = Array("希望日時", "希望数", "該当数", "空枠日時", "空枠数") '希望数で並べ替え 並べ替え Range("AE1").Resize(dic世帯希望.Count + 1, 3) '1行目から End Sub Private Sub 日時枠消込み(ByVal 決定Idx, ByVal 決定日, ByVal 決定時刻) Dim NN As Long, KK As Long, LL As Long For NN = 1 To 日枠総数 With 日時枠s(NN) If .日付 = 決定日 Then For KK = 1 To 時間帯区分数 If 時間区分TBL(1, KK) = 決定時刻 Then For LL = 1 To UBound(.時刻s(KK).軒目s) If .時刻s(KK).軒目s(LL) = 0 Then .時刻s(KK).軒目s(LL) = 決定Idx Exit Sub End If Next LL End If Next KK End If End With Next NN End Sub Private Function getShuffuledOrder(ByVal lastNum As Long) Dim NN As Long Dim 乱数rand() Dim Order() ReDim 乱数(1 To lastNum) ReDim Order(1 To lastNum) For NN = 1 To lastNum 乱数(NN) = Rnd Order(NN) = NN Next NN With Application getShuffuledOrder = .Transpose(.Match(.Small(乱数, Order), 乱数, 0)) End With End Function Private Sub 並べ替え(ByRef rToSort As Range) '並べ替え Me.Sort.SortFields.Clear Me.Sort.SortFields.Add Key:=Range("AF2"), SortOn:=xlSortOnValues, Order:=xlAscending With Me.Sort .SetRange rToSort .Header = xlYes .Orientation = xlTopToBottom .Apply End With End Sub （kuro） 2019/12/04(水) 01:44 ---- 1.mmさんの案の首尾は? ＞第1〜第3に当てはまらない場合 2.H列に「不叶」と出ます。 ＞H、I列に第4希望、J、K列に第5希望の項目を付け足して 3.J列からは、枠数指定のエリアですからトラブります。 列数が多いので、1希望につき1列で処理するように改変せざるを得ません。 つまり、従前のデータ形式を踏襲するものになります。 ただし、頭4桁に年情報が加わった希望日時データが必要になります。 （半平太） 2019/12/04(水) 08:22 ---- お世話になります。 ＞1.mmさんの案の首尾は? 当初、マクロを利用することを想定してなく、 こちらに書き込んだレイアウトと実際の行、列とが違うため うまく機能しませんでした。 ＞3.J列からは、枠数指定のエリアですからトラブります。 差し支えなければ、どのように改変したらよいか 教えて下さいますと幸いです。 （kuro） 2019/12/04(水) 12:16 ---- ＞こちらに書き込んだレイアウトと実際の行、列とが違うため 回答側は、提示されたレイアウトで動作すればいいと思ってレスを入れるのが通例ですので、 そんなことを言い出されたらお手上げです。 解決したければ、実際のレイアウトとデータを示してください。 （半平太） 2019/12/04(水) 13:07 ---- 横からすみません 工事の説明スケジュールと推測しています 提示されたデータで手作業で30分ほどでやってみましたが 37部屋中 希望の時間帯が取れた世帯は 23件でした。 例えば 2019/12/9の9:00 は 第一希望9件、第二希望0第三希望4件で、 かなり偏りがあり、10:00、11:00 は希望がない時間帯も少なくありません 9:00 10:00 11:00 2019/12/9 506 211 410 2019/12/10 411 302 2019/12/11 304 209 501 2019/12/12 207 2019/12/13 101 2019/12/14 104 405 208 2019/12/15 2019/12/16 102 303 2019/12/17 109 402 2019/12/18 404 107 2019/12/19 504 2019/12/20 202 2019/12/21 204 403 家庭の事情を考えると 10時、11時というのは中途半端な時間帯であることも考慮して、 9時台に人員を増やすなどの方策が必要かもしれませんね ほかのケースもあるということですが、慣れないマクロを考えているよりは、手作業で行った方が 結果として効率的だと思いますが。 （渡辺ひかる） 2019/12/04(水) 14:01 ---- エクセル掲示板の回答らしくない答え方をします。 昔こういう訪問工事のお仕事をしましたが、イレギュラーばかりです。 最初に約束してもあとから時間変更を言われたり、訪問しても不在だったり。 訪問できてもゴミ屋敷だったり望外の問題で施工できず再訪問になったり、 他の部屋を終わって出てきたら「ちょうど今都合がいいからやって」と声掛けされたり、 いつまでも無視あるいは拒否され続けて管理会社相談のもと工事中止したり、いろいろです。 とにかく当初の予定通りにはならないことばかりなので プログラム任せで組むのはまったくおすすめしません。 表面に部屋番号、裏面に希望日と連絡先番号を書いた紙の小片をつくり 日付と時間を縦横軸に書いた表に貼り付けてにらめっこするのがおすすめです。 （海苔） 2019/12/04(水) 15:18 ---- >いつまでも無視あるいは拒否され続けて管理会社相談のもと工事中止したり、いろいろです。 耳が痛いです。 ほぼいないので、工事自体知らない事が多い。 （BJ） 2019/12/04(水) 16:28 ---- 意味不明のコメントが続くなぁ。 何にせよ、1秒でたたき台ができれば、 kuroさんの業務効率化になると思うけどね。 （半平太） 2019/12/04(水) 16:38 ---- 思ったより面白そうなので、参戦。 ご提示のデータは、A1セルから詰まっている前提です。 ずれているなら、別ブックにコピーでもしてから、マクロ実行してください。 シートは3つ使います。 1つ目が元データで、2つ目は重複除去するためのテンポラリ（完了すると空になるはず）、3つ目は結果出力用です。 ロジックとしては、希望者の少ない日時から優先的に埋めていくことで、なるべく平均的にバラしています。1件内の希望優先順位は考慮しません。 それでも、今回のデータなら、1時間あたり3件までで収まるようなので、そのまま使えそうに思います。 Sub test() Dim AR As Object Dim AR1 As Object Dim AR2 As Object Dim DIC1 As Object Dim DIC2 As Object Dim wk1 As Worksheet Dim wk2 As Worksheet Dim wk3 As Worksheet Dim R As Range Dim i As Long Dim j As Long Dim n As Long Dim iw As Long Dim cw As String Dim cw1 As String Dim cw2 As String Set AR = CreateObject("System.Collections.ArrayList") Set AR1 = CreateObject("System.Collections.ArrayList") Set AR2 = CreateObject("System.Collections.ArrayList") Set DIC1 = CreateObject("Scripting.Dictionary") Set DIC2 = CreateObject("Scripting.Dictionary") Set wk1 = Sheets("Sheet1") Set wk2 = Sheets("Sheet2") Set wk3 = Sheets("Sheet3") wk2.Cells.Clear wk2.Columns("A:C").NumberFormatLocal = "@" wk3.Cells.Clear wk3.Columns("A:A").NumberFormatLocal = "mm/dd(aaa);@" wk3.Columns("B:D").NumberFormatLocal = "@" For Each R In wk1.Range("B2:D999").SpecialCells(xlCellTypeConstants) iw = InStr(R.Text, "(") AR.Add Format(CDate(Left(R.Text, iw - 1) & Mid(R.Text, iw + 3)), "YYYY/MM/DD HH:NN") & "|" & Cells(R.Row, "A").Value cw = Format(CDate(Left(R.Text, iw - 1)), "YYYY/MM/DD") If AR1.Contains(cw) = False Then AR1.Add cw End If cw = Mid(R.Text, iw + 4) If AR2.Contains(cw) = False Then AR2.Add cw End If Next R AR.Sort AR1.Sort AR2.Sort wk2.Range("A1").Resize(AR.Count, 1) = WorksheetFunction.Transpose(AR.toarray) For i = 1 To AR.Count iw = InStr(AR(i - 1), "|") wk2.Cells(i, "B").Value = Left(AR(i - 1), iw - 1) wk2.Cells(i, "C").Value = Mid(AR(i - 1), iw + 1) Next i wk2.Range("D1:D" & AR.Count).Formula = "=COUNTIF(B:B,B1)" For i = 1 To AR1.Count wk3.Cells(i + 1, "A").Value = AR1(i - 1) DIC1.Add AR1(i - 1), i + 1 Next i For i = 1 To AR2.Count wk3.Cells(1, i + 1).Value = AR2(i - 1) DIC2.Add AR2(i - 1), i + 1 Next i For n = 1 To 5 i = 1 Do Until i < 1 For i = AR.Count To 1 Step -1 If wk2.Cells(i, "D").Value <= n Then cw = wk2.Cells(i, "C").Value cw1 = Left(wk2.Cells(i, "B").Text, 10) cw2 = Right(wk2.Cells(i, "B").Text, 5) If wk3.Cells(DIC1(cw1), DIC2(cw2)).Value = "" Then wk3.Cells(DIC1(cw1), DIC2(cw2)).Value = cw Else wk3.Cells(DIC1(cw1), DIC2(cw2)).Value = wk3.Cells(DIC1(cw1), DIC2(cw2)).Value & vbLf & cw End If For j = AR.Count To 1 Step -1 If wk2.Cells(j, "C").Text = cw Then AR.Remove wk2.Cells(j, "A").Text wk2.Rows(j).Delete End If Next j Exit For End If Next i DoEvents Loop Next n End Sub 第5希望まで取ったとしても、wk1.Range("B2:D999") の部分を変えるだけですよ。 （???） 2019/12/04(水) 17:02 ---- 今回の例だと、第2希望まででも最大3件までに収まるようです。 範囲指定をwk1.Range("B2:C99")としてみてください。 （ついでに999行まで使う事もなさそうなので、99行までに変更） （???） 2019/12/04(水) 17:38 ---- お世話になっております。 返信が遅くなり申し訳ございません。 今後もこのデータを利用するために、下記のように、第5希望まで取れるようにし、N列〜T列の日時枠を6枠までに変更しました。 そのため、出力先は、『U列を空けてV列以降』だと助かります。 第1希望、第2希望…と取っていますが、建前上取っているだけなので、割り振りする際に影響が出るようであれば、優先順位は特に考慮しないつもりです。 また、希望ですが、A列の世帯とN列の日時の項目は、その時その時で変わってきますので、増えても対応できるようにしていただけますと幸いです。 よろしくお願いいたします。 ＞解決したければ、実際のレイアウトとデータを示してください。 データも示さずに申し訳ございませんでした。下記のものでお願い致します。 ＞ほかのケースもあるということですが、慣れないマクロを考えているよりは、手作業で行った方が結果として効率的だと思いますが。 たしかにイレギュラーなことも多いですが、おおまかにでも、自動で決まるといいなと思いました。 ＞表面に部屋番号、裏面に希望日と連絡先番号を書いた紙の小片をつくり、日付と時間を縦横軸に書いた表に貼り付けてにらめっこするのがおすすめです。 ある程度自動で作られると楽だと思いまして。 ＞ほぼいないので、工事自体知らない事が多い。 確かに理解のない人もいて苦労しております。 ＞何にせよ、1秒でたたき台ができれば、kuroさんの業務効率化になると思うけどね。 毎度の作業であったので、効率化が図れればという思いがありました。 ＞???さん 作成していただき有難うございます。 後出しで非常に心苦しいのですが、 下記の場合で適応できるものをご検討いただけますと幸いです。 行 __A__ ____B____ __C__ ____D____ __E__ ____F____ __G__ ____H____ __I__ ____J____ __K__ 01 世帯 第1希望 第2希望 第3希望 第4希望 第5希望 02 101 12/13(金) 09:00 12/11(水) 09:00 12/09(月) 09:00 _________ _____ _________ _____ 03 102 12/16(月) 09:00 12/11(水) 09:00 _________ _____ _________ _____ _________ _____ 04 103 12/14(土) 09:00 12/10(火) 09:00 12/09(月) 09:00 _________ _____ _________ _____ 05 104 12/14(土) 10:00 12/14(土) 11:00 12/14(土) 09:00 _________ _____ _________ _____ 06 105 12/21(土) 09:00 12/14(土) 09:00 _________ _____ _________ _____ _________ _____ 07 106 12/09(月) 09:00 12/10(火) 09:00 12/11(水) 09:00 _________ _____ _________ _____ 08 107 12/18(水) 10:00 12/12(木) 10:00 12/09(月) 10:00 _________ _____ _________ _____ 09 108 _________ _____ _________ _____ _________ _____ _________ _____ _________ _____ 10 109 12/17(火) 09:00 12/20(金) 09:00 12/16(月) 09:00 _________ _____ _________ _____ 11 110 12/21(土) 10:00 12/21(土) 11:00 _________ _____ _________ _____ _________ _____ 12 111 _________ _____ _________ _____ _________ _____ _________ _____ _________ _____ 13 201 12/12(木) 09:00 12/12(木) 10:00 12/12(木) 11:00 _________ _____ _________ _____ : : : : : : : : : : : : 51 506 12/09(月) 09:00 12/09(月) 10:00 12/09(月) 11:00 _________ _____ _________ _____ 行 ___L____ ___M____ ____N____ __O__ __P__ __Q__ __R__ __S__ __T__ 01 決定日時 希望順位 日時(枠) 09:00 10:00 11:00 _____ _____ _____ 02 ________ ________ 12/09(月) 2 2 2 0 0 0 03 ________ ________ 12/10(火) 2 2 2 0 0 0 04 ________ ________ 12/11(水) 2 2 2 0 0 0 05 ________ ________ 12/12(木) 2 2 2 0 0 0 06 ________ ________ 12/13(金) 2 2 2 0 0 0 07 ________ ________ 12/14(土) 2 2 2 0 0 0 08 ________ ________ 12/16(月) 4 4 4 0 0 0 09 ________ ________ 12/17(火) 4 4 4 0 0 0 10 ________ ________ 12/18(水) 4 4 4 0 0 0 11 ________ ________ 12/19(木) 4 4 4 0 0 0 12 ________ ________ 12/20(金) 4 4 4 0 0 0 13 ________ ________ 12/21(土) 4 4 4 0 0 0 : : : 51 ________ ________ （kuro） 2019/12/10(火) 16:53 ---- 面倒だし、効率的ではない表なので、お断りします。 年月日と時刻は、合わせて1つの日付型で格納できるので、1列にすべきでしょう。 「2019/12/9 10:00」のように入力すれば良いだけの事です。 そして、セルの書式で年を削ったり、曜日が出るようにしましょう。 これならマクロの処理が今より簡単にできるので、ロジック変更する余地がありますよ。 また、出力先の列を変えるのは、私はDIC2という変数で出力先の列を表現していますが、これに好きなだけ数字を足すだけで、目的の列に出力できるので、ご自身で調節してみてください。 あと、時間毎の最大数を決めるのは、ロジックが複雑化するだけなので、止めた方が良いと思います。 マクロは希望を割り振ってたたき台を作成するだけにして、後の調整は手作業で行っても十分でしょう? どうしても件数制限付きの新レイアウトが良いというのであれば、半平太さん案を使うだけの話ではないでしょうか。 （???） 2019/12/10(火) 17:26 ---- お世話になります。 ???さん 無理を言ってしまい申し訳ございませんでした。 今回のケースですと50件でしたが、 100件を超えることもあり手動では厳しいものがありまして、 なんとか自動でできればという考えがありました。 半平太さん ＞解決したければ、実際のレイアウトとデータを示してください。 もしよろしければ、上記のデータで作成をお願いできますと幸いです。 今一度ご検討のほど、よろしくお願い申し上げます。 （kuro） 2019/12/17(火) 15:16 ---- ＞もしよろしければ、上記のデータで作成をお願いできますと幸いです。 私は、前に提示したアウトプットのレイアウトを変える気はないです。 そうなると、以前に説明した通りの希望データにして貰わない限り、改変もやりません。 ↓ ＞ 3.J列からは、枠数指定のエリアですからトラブります。 ＞ 列数が多いので、1希望につき1列で処理するように改変せざるを得ません。 ＞ つまり、従前のデータ形式を踏襲するものになります。 ＞ ただし、頭4桁に年情報が加わった希望日時データが必要になります。 つまり、1セルにこんな希望データがある状態 ↓ 2019/12/13(金) 9:00 12/13(金) 9:00 ↑ 従前は1セルにこう入っていたんですから、そんなに問題がないと思うんですがねぇ。 （半平太） 2019/12/17(火) 15:46 ---- 半平太さん お世話になります。 日時を1セルにまとめましたのでご確認ください。 行 _A__ __________B_________ __________C_________ __________D_________ __________E_________ __________F_________ 01 世帯 第1希望 第2希望 第3希望 第4希望 第5希望 02 101 2019 12/13(金) 09:00 2019 12/11(水) 09:00 2019 12/09(月) 09:00 ____________________ ____________________ 03 102 2019 12/16(月) 09:00 2019 12/11(水) 09:00 ____________________ ____________________ ____________________ 04 103 2019 12/14(土) 09:00 2019 12/10(火) 09:00 2019 12/09(月) 09:00 ____________________ ____________________ 05 104 2019 12/14(土) 10:00 2019 12/14(土) 11:00 2019 12/14(土) 09:00 ____________________ ____________________ 06 105 2019 12/21(土) 09:00 2019 12/14(土) 09:00 ____________________ ____________________ ____________________ 07 106 2019 12/09(月) 09:00 2019 12/10(火) 09:00 2019 12/11(水) 09:00 ____________________ ____________________ 08 107 2019 12/18(水) 10:00 2019 12/12(木) 10:00 2019 12/09(月) 10:00 ____________________ ____________________ 09 108 ____________________ ____________________ ____________________ ____________________ ____________________ 10 109 2019 12/17(火) 09:00 2019 12/20(金) 09:00 2019 12/16(月) 09:00 ____________________ ____________________ 11 110 2019 12/21(土) 10:00 2019 12/21(土) 11:00 ____________________ ____________________ ____________________ 12 111 ____________________ ____________________ ____________________ ____________________ ____________________ 13 201 2019 12/12(木) 09:00 2019 12/12(木) 10:00 2019 12/12(木) 11:00 ____________________ ____________________ : : : : : : : 51 506 2019 12/09(月) 09:00 2019 12/09(月) 10:00 2019 12/09(月) 11:00 ____________________ ____________________ 行 __________G_________ ___H____ ____I____ __J__ __K__ __L__ __M__ __N__ __O__ 01 決定日時 希望順位 日時(枠) 09:00 10:00 11:00 _____ _____ _____ 02 ____________________ ________ 12/09(月) 2 2 2 0 0 0 03 ____________________ ________ 12/10(火) 2 2 2 0 0 0 04 ____________________ ________ 12/11(水) 2 2 2 0 0 0 05 ____________________ ________ 12/12(木) 2 2 2 0 0 0 06 ____________________ ________ 12/13(金) 2 2 2 0 0 0 07 ____________________ ________ 12/14(土) 2 2 2 0 0 0 08 ____________________ ________ 12/16(月) 4 4 4 0 0 0 09 ____________________ ________ 12/17(火) 4 4 4 0 0 0 10 ____________________ ________ 12/18(水) 4 4 4 0 0 0 11 ____________________ ________ 12/19(木) 4 4 4 0 0 0 12 ____________________ ________ 12/20(金) 4 4 4 0 0 0 13 ____________________ ________ 12/21(土) 4 4 4 0 0 0 : : : 51 ____________________ ________ （kuro） 2019/12/17(火) 16:32 ---- 日時を1列にまとめたならば、私のロジックでも変更量が減るので、対処できます。 気になったのが、今後も使いまわすのでしょうけど、時間枠が3つ固定で大丈夫なのでしょうか。 まぁ、ご自身で対応するならば何も言いませんが。 Sub test() Dim AR As Object Dim AR1 As Object Dim AR2 As Object Dim DIC As Object Dim DIC1 As Object Dim DIC2 As Object Dim wk1 As Worksheet Dim wk2 As Worksheet Dim R As Range Dim i As Long Dim j As Long Dim n As Long Dim iw As Long Dim cw As String Dim cw1 As String Dim cw2 As String Dim vw As Variant Application.ScreenUpdating = False Set AR = CreateObject("System.Collections.ArrayList") Set AR1 = CreateObject("System.Collections.ArrayList") Set AR2 = CreateObject("System.Collections.ArrayList") Set DIC = CreateObject("Scripting.Dictionary") Set DIC1 = CreateObject("Scripting.Dictionary") Set DIC2 = CreateObject("Scripting.Dictionary") Set wk1 = Sheets("Sheet1") Set wk2 = Sheets("Sheet2") wk1.Range("G2:H99").Clear wk1.Columns("M:O").Clear wk1.Columns("M:O").NumberFormatLocal = "@" wk1.Columns("G:G").NumberFormatLocal = "yyyy/mm/dd(aaa) HH:MM" wk1.Range("H2:H99").Formula = "=IFERROR(MATCH(TEXT($G2,""yyyy/mm/dd(aaa) HH:MM""),$B2:$F2,0),"""")" wk2.Cells.Clear wk2.Columns("A:C").NumberFormatLocal = "@" For i = 2 To wk1.Cells(wk1.Rows.Count, "A").End(xlUp).Row DIC.Add wk1.Cells(i, "A").Text, i Next i For i = 2 To wk1.Cells(wk1.Rows.Count, "I").End(xlUp).Row cw = Format(CDate(Left(wk1.Cells(i, "I").Text, 5)), "YYYY/MM/DD") AR1.Add cw DIC1.Add cw, i Next i For i = 10 To 12 cw = wk1.Cells(1, i).Text AR2.Add cw DIC2.Add cw, i + 3 Next i For Each R In wk1.Range("B2:F99").SpecialCells(xlCellTypeConstants) iw = InStr(R.Text, "(") AR.Add Format(CDate(Left(R.Text, iw - 1) & Mid(R.Text, iw + 3)), "YYYY/MM/DD HH:NN") & "|" & Cells(R.Row, "A").Value Next R AR.Sort wk2.Range("A1").Resize(AR.Count, 1) = WorksheetFunction.Transpose(AR.toarray) For i = 1 To AR.Count iw = InStr(AR(i - 1), "|") wk2.Cells(i, "B").Value = Left(AR(i - 1), iw - 1) wk2.Cells(i, "C").Value = Mid(AR(i - 1), iw + 1) Next i wk2.Range("D1:D" & AR.Count).Formula = "=COUNTIF(B:B,B1)" For n = 1 To 9 i = 1 Do Until i < 1 For i = AR.Count To 1 Step -1 If wk2.Cells(i, "D").Value <= n Then cw = wk2.Cells(i, "C").Value cw1 = Left(wk2.Cells(i, "B").Text, 10) cw2 = Right(wk2.Cells(i, "B").Text, 5) vw = Split(wk1.Cells(DIC1(cw1), DIC2(cw2)).Value, vbLf) If UBound(vw) + 1 < wk1.Cells(DIC1(cw1), DIC2(cw2) - 3).Value Then If wk1.Cells(DIC1(cw1), DIC2(cw2)).Value = "" Then wk1.Cells(DIC1(cw1), DIC2(cw2)).Value = cw Else wk1.Cells(DIC1(cw1), DIC2(cw2)).Value = wk1.Cells(DIC1(cw1), DIC2(cw2)).Value & vbLf & cw End If For j = AR.Count To 1 Step -1 If wk2.Cells(j, "C").Text = cw Then If cw1 & " " & cw2 = wk2.Cells(j, "B").Value Then wk1.Cells(DIC(wk2.Cells(j, "C").Value), "G") = cw1 & " " & cw2 End If AR.Remove wk2.Cells(j, "A").Text wk2.Rows(j).Delete End If Next j Exit For End If End If Next i DoEvents Loop Next n Application.ScreenUpdating = True End Sub （???） 2019/12/17(火) 18:35 ---- あ、希望日時の書き方ですが、「2019 12/13(金) 09:00」だと入力も処理も面倒なので、「2019/12/13(金) 09:00」の書き間違いだろうと解釈しました。 年またぎがあるのですかね? （???） 2019/12/17(火) 18:39 ---- 私の掲示したレイアウトを見てないですね。 ※日時枠の指定はJ列からなんですけど。。 まぁ、???さんがカンバックしたので、そちらにお任せします。 （半平太） 2019/12/18(水) 08:01 ---- お世話になります。 ＞気になったのが、今後も使いまわすのでしょうけど、時間枠が3つ固定で大丈夫なのでしょうか。 日時枠はJ〜O列の6枠確保しておりました。 2019/12/13(金) 09:00の表記で問題ございません。 年またぎはあるかもしれません。 ＞ ※日時枠の指定はJ列からなんですけど。。 申し訳ございません、見落としておりました。 （kuro） 2019/12/18(水) 10:25 ---- 半平太さん お世話になります。 日時をJ列に変更しました。 行 _A__ __________B_________ __________C_________ __________D_________ __________E_________ __________F_________ 01 世帯 第1希望 第2希望 第3希望 第4希望 第5希望 02 101 2019 12/13(金) 09:00 2019 12/11(水) 09:00 2019 12/09(月) 09:00 ____________________ ____________________ 03 102 2019 12/16(月) 09:00 2019 12/11(水) 09:00 ____________________ ____________________ ____________________ 04 103 2019 12/14(土) 09:00 2019 12/10(火) 09:00 2019 12/09(月) 09:00 ____________________ ____________________ 05 104 2019 12/14(土) 10:00 2019 12/14(土) 11:00 2019 12/14(土) 09:00 ____________________ ____________________ 06 105 2019 12/21(土) 09:00 2019 12/14(土) 09:00 ____________________ ____________________ ____________________ 07 106 2019 12/09(月) 09:00 2019 12/10(火) 09:00 2019 12/11(水) 09:00 ____________________ ____________________ 08 107 2019 12/18(水) 10:00 2019 12/12(木) 10:00 2019 12/09(月) 10:00 ____________________ ____________________ 09 108 ____________________ ____________________ ____________________ ____________________ ____________________ 10 109 2019 12/17(火) 09:00 2019 12/20(金) 09:00 2019 12/16(月) 09:00 ____________________ ____________________ 11 110 2019 12/21(土) 10:00 2019 12/21(土) 11:00 ____________________ ____________________ ____________________ 12 111 ____________________ ____________________ ____________________ ____________________ ____________________ 13 201 2019 12/12(木) 09:00 2019 12/12(木) 10:00 2019 12/12(木) 11:00 ____________________ ____________________ : : : : : : : 51 506 2019 12/09(月) 09:00 2019 12/09(月) 10:00 2019 12/09(月) 11:00 ____________________ ____________________ 行 __________G_________ ___H____ __I__ ____J____ __K__ __L__ __M__ __N__ __O__ __P__ 01 決定日時 希望順位 日時(枠) 09:00 10:00 11:00 _____ _____ _____ 02 ____________________ ________ 12/09(月) 2 2 2 0 0 0 03 ____________________ ________ 12/10(火) 2 2 2 0 0 0 04 ____________________ ________ 12/11(水) 2 2 2 0 0 0 05 ____________________ ________ 12/12(木) 2 2 2 0 0 0 06 ____________________ ________ 12/13(金) 2 2 2 0 0 0 07 ____________________ ________ 12/14(土) 2 2 2 0 0 0 08 ____________________ ________ 12/16(月) 4 4 4 0 0 0 09 ____________________ ________ 12/17(火) 4 4 4 0 0 0 10 ____________________ ________ 12/18(水) 4 4 4 0 0 0 11 ____________________ ________ 12/19(木) 4 4 4 0 0 0 12 ____________________ ________ 12/20(金) 4 4 4 0 0 0 13 ____________________ ________ 12/21(土) 4 4 4 0 0 0 : : : 51 ____________________ ________ （kuro） 2019/12/18(水) 10:33 ---- むぅ、I列1列挿入ですか。 元のレイアウトには無かったでしょうに…。 そして、時間枠は6列ですか。 元は日付と時間の交点に部屋を表示していたので、後ろ3列はそのために空けてあるのかと思いましたよ。 自分でコード書いていないと、つまらない変更に対応する徒労感なんて判らないのでしょうね。 ほいほい変更を頼むのではなく、まずは自分で直そうとしてみてくれれば、手伝う気にもなるのですけど。 Sub test() Dim AR As Object Dim AR1 As Object Dim AR2 As Object Dim DIC As Object Dim DIC1 As Object Dim DIC2 As Object Dim wk1 As Worksheet Dim wk2 As Worksheet Dim R As Range Dim i As Long Dim j As Long Dim n As Long Dim iw As Long Dim cw As String Dim cw1 As String Dim cw2 As String Dim vw As Variant Application.ScreenUpdating = False Set AR = CreateObject("System.Collections.ArrayList") Set AR1 = CreateObject("System.Collections.ArrayList") Set AR2 = CreateObject("System.Collections.ArrayList") Set DIC = CreateObject("Scripting.Dictionary") Set DIC1 = CreateObject("Scripting.Dictionary") Set DIC2 = CreateObject("Scripting.Dictionary") Set wk1 = Sheets("Sheet1") Set wk2 = Sheets("Sheet2") wk1.Range("G2:H99").Clear wk1.Columns("P:U").Clear wk1.Columns("P:U").NumberFormatLocal = "@" wk1.Columns("G:G").NumberFormatLocal = "yyyy/mm/dd(aaa) HH:MM" wk1.Range("H2:H99").Formula = "=IFERROR(MATCH(TEXT($G2,""yyyy/mm/dd(aaa) HH:MM""),$B2:$F2,0),"""")" wk2.Cells.Clear wk2.Columns("A:C").NumberFormatLocal = "@" For i = 2 To wk1.Cells(wk1.Rows.Count, "A").End(xlUp).Row DIC.Add wk1.Cells(i, "A").Text, i Next i For i = 2 To wk1.Cells(wk1.Rows.Count, "J").End(xlUp).Row cw = Format(CDate(Left(wk1.Cells(i, "J").Text, 5)), "YYYY/MM/DD") AR1.Add cw DIC1.Add cw, i Next i For i = 11 To 16 cw = wk1.Cells(1, i).Text If cw <> "" Then AR2.Add cw DIC2.Add cw, i + 6 End If Next i For Each R In wk1.Range("B2:F99").SpecialCells(xlCellTypeConstants) iw = InStr(R.Text, "(") AR.Add Format(CDate(Left(R.Text, iw - 1) & Mid(R.Text, iw + 3)), "YYYY/MM/DD HH:NN") & "|" & Cells(R.Row, "A").Value Next R AR.Sort wk2.Range("A1").Resize(AR.Count, 1) = WorksheetFunction.Transpose(AR.toarray) For i = 1 To AR.Count iw = InStr(AR(i - 1), "|") wk2.Cells(i, "B").Value = Left(AR(i - 1), iw - 1) wk2.Cells(i, "C").Value = Mid(AR(i - 1), iw + 1) Next i wk2.Range("D1:D" & AR.Count).Formula = "=COUNTIF(B:B,B1)" For n = 1 To 9 i = 1 Do Until i < 1 For i = AR.Count To 1 Step -1 If wk2.Cells(i, "D").Value <= n Then cw = wk2.Cells(i, "C").Value cw1 = Left(wk2.Cells(i, "B").Text, 10) cw2 = Right(wk2.Cells(i, "B").Text, 5) vw = Split(wk1.Cells(DIC1(cw1), DIC2(cw2)).Value, vbLf) If UBound(vw) + 1 < wk1.Cells(DIC1(cw1), DIC2(cw2) - 6).Value Then If wk1.Cells(DIC1(cw1), DIC2(cw2)).Value = "" Then wk1.Cells(DIC1(cw1), DIC2(cw2)).Value = cw Else wk1.Cells(DIC1(cw1), DIC2(cw2)).Value = wk1.Cells(DIC1(cw1), DIC2(cw2)).Value & vbLf & cw End If For j = AR.Count To 1 Step -1 If wk2.Cells(j, "C").Text = cw Then If cw1 & " " & cw2 = wk2.Cells(j, "B").Value Then wk1.Cells(DIC(wk2.Cells(j, "C").Value), "G") = cw1 & " " & cw2 End If AR.Remove wk2.Cells(j, "A").Text wk2.Rows(j).Delete End If Next j Exit For End If End If Next i DoEvents Loop Next n Application.ScreenUpdating = True End Sub （???） 2019/12/18(水) 11:18 ---- ＞日時をJ列に変更しました。 うーん、???さんにお任せする気だったんですけども。。 1.まず、データの素性の確認です。 (1)希望データは、文字列で「2019/12/17(火) 9:00」と言う様な具合になっている事 (2)一方、J列の日付は、日付シリアル値が入っており、書式の設定で「12/9(月)」などと見せている事 ※ 書式はそちらの都合であって、実際はどんな書式でも構いません。 (3)日時枠の時刻データは、全て手入力で行っている事 つまり、9:00、10:00と入れた後、フィルドラッグで11:00、12:00、13:00 等とはしていない事 ※ エクセルに自動計算させると、小数演算誤差が悪さをすることがあるで。 2.結果表示エリアの移動 日時枠の時刻帯が3区分より増えてくると、右方にある結果表示エリアに被さり始めるので、 結果表示は、日時枠数指定エリアの下に表示することにします。 ※ 日時枠数指定エリアが何行であっても、その下に1行空けて、自動的に結果を表示します。 3.プログラムの貼り付け先 当該シートのシートモジュールとする(すなわち標準モジュールではないです） 4.プログラムの変更 長いので変更箇所のみです。 <宣言部分>---------------------------- ＞ Const 時間帯区分数 As Long = 3 ＞ Const 希望可能数 As Long = 3 ↓ Const 時間帯区分数 As Long = 6 '予想される最大区分数(実データがそれより少なくても構わない） Const 希望可能数 As Long = 6 '予想される最大希望数(実データがそれより少なくても構わない） <世帯情報格納>プロシージャ--------------------------- ＞ If 世帯TBL(Idx, CL * 2) <> "" Then ＞ .希望s(CL).日付 = 世帯TBL(Idx, CL * 2) ＞ .希望s(CL).時刻 = 世帯TBL(Idx, CL * 2 + 1) ↓ If 世帯TBL(Idx, CL + 1) <> "" Then .希望s(CL).日付 = CDate(Replace(Split(世帯TBL(Idx, CL + 1), "(")(0), " ", "")) .希望s(CL).時刻 = CDate(Replace(Split(世帯TBL(Idx, CL + 1), ")")(1), " ", "")) <日時枠情報格納>プロシージャ---------------------------------- ＞ 日枠総数 = Cells(Rows.Count, "J").End(xlUp).Row - 1 ↓ 日枠総数 = Cells(1, "J").End(xlDown).Row - 1 ＞ Stop ↓ ReDim .時刻s(CL).軒目s(0 To 0) <ShowResult>このプロシージャは以下に全取換え---------------------- Private Sub showResult() '結果打ち出し Dim Idx As Long, Rw As Long, CL As Long, Done As Boolean Dim 決定日, 決定時刻 Range("J1").Offset(日枠総数 + 2, 0).Resize(500, 15).ClearContents Range("J1").Offset(日枠総数 + 2).Resize(日枠総数 + 1, 時間帯区分数 + 1).Value = 日時枠TBL With Range("H2").Resize(世帯総数, 1) .Formula = "=IF(COUNTA(B2:G2)=0,""無回答"",""不叶"")" .Value = .Value End With For Idx = 1 To 世帯総数 With 世帯s(Idx) If Not IsEmpty(.決定日時) Then 決定日 = CDate(Format(Left(.決定日時, 8), "0000/00/00")) 決定時刻 = CDate(Format(Right(.決定日時, 4), "00:00")) Done = False For Rw = 2 To UBound(日時枠TBL) If 日時枠TBL(Rw, 1) = 決定日 Then For CL = 2 To UBound(日時枠TBL, 2) If 日時枠TBL(1, CL) = 決定時刻 Then 結果TBL(Rw, CL) = 結果TBL(Rw, CL) & " " & .部屋番号 & "号" Cells(Idx + 1, 8).Value = 決定日 + 決定時刻 Done = True Exit For End If Next CL If Done Then Exit For End If End If Next End If End With Next Idx With Range("J1").Offset(日枠総数 + 3, 1).Resize(日枠総数, 時間帯区分数) .Value = 結果TBL .Value = Me.Evaluate("INDEX(SUBSTITUTE(TRIM(" & .Address & "),"" "",""、""),0,0)") End With Range("I1").Value = "希望順位" With Range("I2").Resize(世帯総数, 1) .Formula = "=IF(OR(H2={""無回答"",""不叶""}),"""",MATCH(TEXT(H2,""yyyy/m/d(aaa) h:mm""),B2:G2,0))" End With Columns("J").Resize(, 時間帯区分数 + 1).AutoFit End Sub <結果図> 行 ___A___ __________B__________ __________C__________ __________D__________ _________ E _________ __ F __ ___G___ __________H__________ ___ I ___ ___ J ___ ______K______ _____ L _____ __M__ __N__ 1 世帯idx 第1希望 第2希望 第3希望 第4希望 第5希望 第6希望 決定 希望順位 日時枠 9:00 10:00 11:00 12:00 2 101 2019/12/13(金) 9:00 2019/12/11(水) 9:00 2019/12/9(月) 9:00 2019/12/13(金) 9:00 1 12/9(月) 2 2 1 1 3 102 2019/12/16(月) 9:00 2019/12/11(水) 9:00 2019/12/16(月) 9:00 1 12/10(火) 2 2 1 4 103 2019/12/14(土) 9:00 2019/12/10(火) 9:00 2019/12/9(月) 9:00 2019/12/10(火) 9:00 2 12/11(水) 2 2 1 5 104 2019/12/14(土) 9:00 2019/12/14(土) 10:00 2019/12/14(土) 11:00 2019/12/14(土) 11:00 3 12/12(木) 2 2 1 6 105 2019/12/14(土) 9:00 2019/12/21(土) 9:00 2019/12/21(土) 9:00 2 12/13(金) 2 2 1 7 106 2019/12/9(月) 9:00 2019/12/10(火) 9:00 2019/12/11(水) 9:00 2019/12/9(月) 9:00 1 12/14(土) 2 2 1 8 107 2019/12/18(水) 10:00 2019/12/12(木) 10:00 2019/12/9(月) 10:00 2019/12/18(水) 10:00 1 12/16(月) 4 4 1 9 108 無回答 12/17(火) 4 4 1 10 109 2019/12/17(火) 9:00 2019/12/20(金) 9:00 2019/12/16(月) 9:00 2019/12/17(火) 9:00 1 12/18(水) 4 4 1 11 110 2019/12/23(月) 9:00 2019/12/23(月) 9:00 1 12/19(木) 4 4 1 12 111 無回答 12/20(金) 4 4 1 13 201 2019/12/22(月) 10:00 2019/12/22(月) 9:00 2019/12/22(月) 9:00 2019/12/23(月) 14:00 不叶 12/21(土) 4 4 1 14 202 2019/12/20(金) 9:00 2019/12/13(金) 9:00 2019/12/16(月) 9:00 2019/12/20(金) 9:00 1 12/22(日) 15 203 無回答 12/23(月) 1 16 204 2019/12/17(火) 9:00 2019/12/19(木) 9:00 2019/12/21(土) 9:00 2019/12/17(火) 9:00 1 17 205 無回答 日時枠 9:00 10:00 11:00 12:00 18 206 2019/12/13(金) 9:00 2019/12/14(土) 9:00 2019/12/14(土) 9:00 2 12/9(月) 106号、210号 505号、506号 19 207 2019/12/12(木) 9:00 2019/12/16(月) 9:00 2019/12/19(木) 9:00 2019/12/19(木) 9:00 3 12/10(火) 103号 211号 20 208 2019/12/14(土) 11:00 2019/12/21(土) 11:00 2019/12/21(土) 11:00 2 12/11(水) 304号、305号 209号 302号 21 209 2019/12/11(水) 10:00 2019/12/12(木) 10:00 2019/12/18(水) 10:00 2019/12/11(水) 10:00 1 12/12(木) 409号、411号 22 210 2019/12/9(月) 9:00 2019/12/10(火) 9:00 2019/12/13(金) 9:00 2019/12/9(月) 9:00 1 12/13(金) 101号、406号 501号 23 211 2019/12/9(月) 10:00 2019/12/10(火) 10:00 2019/12/16(月) 10:00 2019/12/10(火) 10:00 2 12/14(土) 206号、503号 311号、405号 104号 24 301 無回答 12/16(月) 102号、308号 303号 410号 25 302 2019/12/11(水) 10:00 2019/12/11(水) 11:00 2019/12/17(火) 10:00 2019/12/11(水) 11:00 2 12/17(火) 109号、204号 402号 26 303 2019/12/16(月) 9:00 2019/12/16(月) 10:00 2019/12/16(月) 11:00 2019/12/16(月) 10:00 2 12/18(水) 404号 107号 27 304 2019/12/11(水) 9:00 2019/12/10(火) 9:00 2019/12/9(月) 9:00 2019/12/11(水) 9:00 1 12/19(木) 207号 28 305 2019/12/9(月) 9:00 2019/12/10(火) 9:00 2019/12/11(水) 9:00 2019/12/11(水) 9:00 3 12/20(金) 202号、504号 29 306 2019/12/14(土) 9:00 2019/12/21(土) 9:00 2019/12/21(土) 9:00 2 12/21(土) 105号、306号 403号 208号 30 307 無回答 12/22(日) 31 308 2019/12/9(月) 9:00 2019/12/16(月) 9:00 2019/12/16(月) 9:00 2 12/23(月) 110号 （半平太） 2019/12/18(水) 12:18 ---- お世話になります。 ???さん ＞ほいほい変更を頼むのではなく、まずは自分で直そうとしてみてくれれば、手伝う気にもなるのですけど。 色々と申し訳ございませんでした。 これを期に、勉強していきたいと思っております。 半平太さん ありがとうございます。 上記のように修正した結果、下記のような表が出力されました。 J列の日付の表記と15行目の時間の表記を、半平太さんのものと違うのは どういった原因が考えられますでしょうか ____J____ __K__ ________L________ ________M________ 15 日時枠 0.375 0.416666666666667 0.458333333333333 16 2019/12/9 __号 __号 __号 17 2019/12/10 __号 __号 __号 18 2019/12/11 __号 __号 __号 : : : : : 27 2019/12/21 __号 __号 __号 （kuro） 2019/12/21(土) 17:43 ---- ＞どういった原因が考えられますでしょうか 1.プログラムの修正が正しく行われていない。 2.アンケートデータ、および日時枠の指定データが、想定通りに書き込まれていない。 まず、上記1を確実にする必要があります。 以前書いた場所に修正後のコードを上書きしておきますので、全面コピペしてから実行してみてください。 ↓ (半平太) 2019/12/03(火) 16:49 （半平太） 2019/12/21(土) 19:21... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201911/20191130210527.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97012 documents and 608132 words.
訪問者：