[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『希望調査結果の振り分けについて』（kuro）
希望調査結果の振り分けについて。
例えば、工事で１つのマンション30世帯に訪問するとして、時間の希望を取ります。
12/2(月)〜12/7(土)、各曜日9：00、10：00、11：00それぞれ２枠ずつ、
合計で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
部屋番号 第１希望 第２希望 第３希望
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
１．タイトルとセルのアドレスを加味すると、下図の様になっていると考えていいですか？
<レイアウト確認用> 行 ____A____ ____B____ __C__ ____D____ _ E _ ___ F ___ __G__ 1 部屋番号 第１希望 第２希望 第３希望 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,D,F列にある日付データに曜日が書かれていますが、実体は日付シリアル値であって、 「セルの書式」を設定して、そう見えるようにしているんですね？
（半平太） 2019/12/02(月) 21:09
<レイアウト確認用> 行 ____A____ ________B_______ ________C_______ ________D_______ 1 部屋番号 第１希望 第２希望 第３希望 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
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 部屋番号 第１希望 第２希望 第３希望
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
希望にそえない場合はどのような表示になるのでしょうか。
また、今後、別件でもこのデータの利用を考えているのですが、
世帯数、希望数（第１希望〜第５希望に増やす）、期間等を変更しても
問題なく利用できるのでしょうか。
もし、利用できない場合は、変更する箇所など教えていただければ幸いです。
（kuro） 2019/12/03(火) 17:20
まずは、mmさんのが簡単に処理できているようなので、そちらを当たってください。
＞希望にそえない場合はどのような表示になるのでしょうか。
ちょっと意味が分からないです。前提が違うのでプログラムはトラブるだけです。
＞世帯数、希望数（第１希望〜第５希望に増やす）、期間等を変更しても
世帯数は何も問題ないですが、 列数が想定外に多くなるので、1希望につき1列で処理するように改変せざるを得ません。
データは、今そちらにあるデータのような形式になりそう。
現在は、年情報が無いですが(無いままでもできないわけではないですが）、あった方が安全。
数式としてはこう変えるだけですから、ちょっとの手間を惜しんで ストレスを溜める事もないと思いますけどね。 ↓ =TEXT(G1, "yyyy/m/d(aaa)")&TEXT(H1," hh:mm")
（半平太） 2019/12/03(火) 19:13
希望にそえない場合は〜というのは、第１〜第３に当てはまらない場合の表記のことでした。
説明不足で申し訳ございません。
また、H、I列に第４希望、J、K列に第５希望の項目を付け足してみて、マクロのモジュールを編集してみたのですが、実行すると、「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
１．mmさんの案の首尾は？
＞第１〜第３に当てはまらない場合 ２．H列に「不叶」と出ます。
＞H、I列に第４希望、J、K列に第５希望の項目を付け足して
３．J列からは、枠数指定のエリアですからトラブります。
列数が多いので、1希望につき1列で処理するように改変せざるを得ません。
つまり、従前のデータ形式を踏襲するものになります。
ただし、頭4桁に年情報が加わった希望日時データが必要になります。
（半平太） 2019/12/04(水) 08:22
＞１．mmさんの案の首尾は？
当初、マクロを利用することを想定してなく、
こちらに書き込んだレイアウトと実際の行、列とが違うため
うまく機能しませんでした。
＞３．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
意味不明のコメントが続くなぁ。
何にせよ、１秒でたたき台ができれば、 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
＞解決したければ、実際のレイアウトとデータを示してください。
データも示さずに申し訳ございませんでした。下記のものでお願い致します。
＞ほかのケースもあるということですが、慣れないマクロを考えているよりは、手作業で行った方が結果として効率的だと思いますが。
たしかにイレギュラーなことも多いですが、おおまかにでも、自動で決まるといいなと思いました。
＞表面に部屋番号、裏面に希望日と連絡先番号を書いた紙の小片をつくり、日付と時間を縦横軸に書いた表に貼り付けてにらめっこするのがおすすめです。
ある程度自動で作られると楽だと思いまして。
＞ほぼいないので、工事自体知らない事が多い。
確かに理解のない人もいて苦労しております。
＞何にせよ、１秒でたたき台ができれば、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
???さん
無理を言ってしまい申し訳ございませんでした。
今回のケースですと５０件でしたが、
１００件を超えることもあり手動では厳しいものがありまして、
なんとか自動でできればという考えがありました。
半平太さん
＞解決したければ、実際のレイアウトとデータを示してください。
もしよろしければ、上記のデータで作成をお願いできますと幸いです。
今一度ご検討のほど、よろしくお願い申し上げます。
（kuro） 2019/12/17(火) 15:16
＞もしよろしければ、上記のデータで作成をお願いできますと幸いです。
私は、前に提示したアウトプットのレイアウトを変える気はないです。
そうなると、以前に説明した通りの希望データにして貰わない限り、改変もやりません。 ↓ ＞ ３．J列からは、枠数指定のエリアですからトラブります。 ＞ 列数が多いので、1希望につき1列で処理するように改変せざるを得ません。 ＞ つまり、従前のデータ形式を踏襲するものになります。 ＞ ただし、頭4桁に年情報が加わった希望日時データが必要になります。
つまり、１セルにこんな希望データがある状態
↓
2019/12/13(金) 9:00
12/13(金) 9:00 ↑ 従前は１セルにこう入っていたんですから、そんなに問題がないと思うんですがねぇ。
（半平太） 2019/12/17(火) 15:46
行 _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
気になったのが、今後も使いまわすのでしょうけど、時間枠が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
私の掲示したレイアウトを見てないですね。 ※日時枠の指定はJ列からなんですけど。。
まぁ、???さんがカンバックしたので、そちらにお任せします。
（半平太） 2019/12/18(水) 08:01
日時枠はＪ〜Ｏ列の６枠確保しておりました。
2019/12/13(金) 09:00の表記で問題ございません。
年またぎはあるかもしれません。
＞ ※日時枠の指定はJ列からなんですけど。。
申し訳ございません、見落としておりました。
（kuro） 2019/12/18(水) 10:25
行 _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
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)希望データは、文字列で「2019/12/17(火) 9:00」と言う様な具合になっている事
(2)一方、J列の日付は、日付シリアル値が入っており、書式の設定で「12/9(月)」などと見せている事
※ 書式はそちらの都合であって、実際はどんな書式でも構いません。
(3)日時枠の時刻データは、全て手入力で行っている事 つまり、9:00、10:00と入れた後、フィルドラッグで11:00、12:00、13:00 等とはしていない事 ※ エクセルに自動計算させると、小数演算誤差が悪さをすることがあるで。
２．結果表示エリアの移動 日時枠の時刻帯が3区分より増えてくると、右方にある結果表示エリアに被さり始めるので、 結果表示は、日時枠数指定エリアの下に表示することにします。 ※ 日時枠数指定エリアが何行であっても、その下に1行空けて、自動的に結果を表示します。
３．プログラムの貼り付け先 当該シートのシートモジュールとする(すなわち標準モジュールではないです）
４．プログラムの変更 長いので変更箇所のみです。
<宣言部分>---------------------------- ＞ 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
＞どういった原因が考えられますでしょうか
１．プログラムの修正が正しく行われていない。 ２．アンケートデータ、および日時枠の指定データが、想定通りに書き込まれていない。
まず、上記１を確実にする必要があります。
以前書いた場所に修正後のコードを上書きしておきますので、全面コピペしてから実行してみてください。
↓
(半平太) 2019/12/03(火) 16:49
（半平太） 2019/12/21(土) 19:21
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.