一応、作成してみましたが、要件が不明瞭なので、違っていたら、ごめんなさい。その場合は、諦めるか、適宜に修正してください
◆前提条件
・A(1006)シートをアクティブにした状態で実施してください。
・「ｘ階」の各シートは、A列と１行目の「構成」および「値」は同じものとします。
・「全表」シートの全セルを一旦削除します。
・「日付」や「時刻」にみえるセルは、日付・時刻書式で設定されているものとします。つまり、Excel認識の日付・時刻です。
・対象セルに「色付け」しています。ダメであれば、コメントにしてください。
Sub sample()
Const s階 As String = \u0026quot;2階,3階,4階\u0026quot; ''対象階
Dim ws As Worksheet, sFloor As String, sFloorMsg As String
Dim iLastRow As Long, sDayOfWeek As String, ii As Long, jj As Long
''各階の初期化する。
For Each ws In Sheets(Split(s階, \u0026quot;,\u0026quot;))
''各階の既存値をクリアする。
With ws.Range(\u0026quot;A1\u0026quot;).CurrentRegion
.Offset(1, 1).Resize(.Rows.CountLarge - 1, .Columns.CountLarge - 1).ClearContents
End With
Next ws
Set ws = Nothing
''各階に設定する。
sFloorMsg = \u0026quot;\u0026quot;
iLastRow = Cells(Rows.CountLarge, \u0026quot;B\u0026quot;).End(xlUp).Row
For jj = 3 To Cells(1, Columns.CountLarge).End(xlToLeft).Column Step 2
sDayOfWeek = Format(Cells(1, jj).Value, \u0026quot;aaa\u0026quot;)
For ii = 2 To iLastRow
If Cells(ii, jj).Value Like \u0026quot;*(*)*\u0026quot; Then
''階数を求める。
With Cells(ii, jj)
sFloor = Mid(.Value, InStr(.Value, \u0026quot;(\u0026quot;) + 1)
sFloor = Left(sFloor, InStr(sFloor, \u0026quot;)\u0026quot;) - 1) \u0026amp; \u0026quot;階\u0026quot;
If InStr(\u0026quot;,\u0026quot; \u0026amp; s階, \u0026quot;,\u0026quot; \u0026amp; sFloor) \u0026gt; 0 Then
If 階設定(ThisWorkbook.Sheets(sFloor), .Offset(, -1), sDayOfWeek) Then
.Interior.Color = RGB(221, 235, 247)
Else
sFloorMsg = sFloorMsg \u0026amp; \u0026quot;,\u0026quot; \u0026amp; Cells(ii, jj).Address(False, False)
.Interior.Color = vbYellow
End If
Else
sFloorMsg = sFloorMsg \u0026amp; \u0026quot;,\u0026quot; \u0026amp; Cells(ii, jj).Address(False, False)
.Interior.Color = vbYellow
End If
End With
End If
Next ii
Next jj
''全表に集約する。
If sFloorMsg = \u0026quot;\u0026quot; Then
Call 全表作成(s階)
MsgBox \u0026quot;処理が終了しましたm(__)m\u0026quot;, vbInformation
Else
MsgBox \u0026quot;「\u0026quot; \u0026amp; Mid(sFloorMsg, 2) \u0026amp; \u0026quot;」のセルが処理できません！！\u0026quot;, vbExclamation
End If
End Sub
Private Function 階設定(ByVal ws As Worksheet, ByVal rBase As Range, ByVal sDayOfWeek As String) As Boolean
Dim vTimes As Variant, rg As Range, iCount As Long, ii As Long, jj As Long
''階数を求める。
階設定 = False ''省略値
''曜日列を抽出する。
On Error Resume Next
jj = 0
jj = Application.WorksheetFunction.Match(sDayOfWeek, ws.Rows(1), 0)
On Error GoTo 0
If jj \u0026lt;= 0 Then
MsgBox \u0026quot;「\u0026quot; \u0026amp; ws.Name \u0026amp; \u0026quot;」シートに「\u0026quot; \u0026amp; sDayOfWeek \u0026amp; \u0026quot;」曜日がありません。\u0026quot;, vbExclamation
Exit Function
End If
''時間行を抽出する。
ii = 2
Do While ii \u0026lt;= ws.Cells(ws.Rows.CountLarge, \u0026quot;A\u0026quot;).End(xlUp).Row
With ws.Cells(ii, \u0026quot;A\u0026quot;)
vTimes = Split(.Value, \u0026quot;～\u0026quot;)
If rBase.Value \u0026gt;= TimeValue(vTimes(0)) And rBase.Value \u0026lt;= TimeValue(vTimes(1)) Then
ii = ii + ws.Rows.CountLarge
Else
ii = ii + .MergeArea.Rows.CountLarge
End If
End With
Loop
If ii \u0026lt;= ws.Rows.CountLarge Then
MsgBox \u0026quot;「\u0026quot; \u0026amp; ws.Name \u0026amp; \u0026quot;」シートに時刻「\u0026quot; \u0026amp; Format(rBase.Offset(, -1).Value, \u0026quot;hh:mm\u0026quot;) \u0026amp; \u0026quot;」がありません！！\u0026quot;, vbExclamation
Exit Function
End If
''「時間行、曜日列」にデータを設定する。
ii = ii - ws.Rows.CountLarge
Set rg = ws.Cells(ii, jj).Resize(ws.Cells(ii, \u0026quot;A\u0026quot;).MergeArea.CountLarge, ws.Cells(1, jj).MergeArea.CountLarge)
iCount = Application.WorksheetFunction.CountA(rg)
If iCount \u0026gt;= rg.CountLarge Then
MsgBox \u0026quot;「\u0026quot; \u0026amp; ws.Name \u0026amp; \u0026quot;」シートの「\u0026quot; \u0026amp; rg.Address(False, False) \u0026amp; \u0026quot;」セル範囲に設定できません！！\u0026quot;, vbExclamation
Exit Function
Else
rg(iCount + 1).Value = rBase.Offset(, 1).Value
階設定 = True
End If
Set rg = Nothing
End Function
Private Sub 全表作成(ByVal s階 As String)
Dim sh As Worksheet, ws As Worksheet
Dim iColumCount As Long, rLastRow As Range, rg As Range
Dim rSetRow As Range, ii As Long
''タイトル行を設定する。
Set sh = ThisWorkbook.Sheets(\u0026quot;全表\u0026quot;)
sh.Cells.Delete
With ThisWorkbook.Sheets(Split(s階, \u0026quot;,\u0026quot;)(0))
.Rows(1).Copy sh.Rows(1)
sh.Range(\u0026quot;A1\u0026quot;).EntireColumn.Insert
sh.Range(\u0026quot;A1\u0026quot;).Value = \u0026quot;時刻\u0026quot;
sh.Range(\u0026quot;B1\u0026quot;).Value = \u0026quot;階\u0026quot;
Set rLastRow = .Cells(.Rows.CountLarge, \u0026quot;A\u0026quot;).End(xlUp)
iColumCount = .Cells(1, .Columns.CountLarge).End(xlToLeft).Offset(, 1).Column - 1
Set rg = .Range(\u0026quot;A2\u0026quot;)
End With
''各階データをコピーする。
Set rSetRow = sh.Range(\u0026quot;B2\u0026quot;)
Do While rg.Row \u0026lt;= rLastRow.Row
For Each ws In ThisWorkbook.Sheets(Split(s階, \u0026quot;,\u0026quot;))
ws.Cells(rg.Row, \u0026quot;A\u0026quot;).MergeArea.Resize(, iColumCount).Copy rSetRow
rSetRow.Offset(, -1).Resize(rg.MergeArea.CountLarge).Value = rSetRow.Value
rSetRow.Value = ws.Name
Set rSetRow = rSetRow.Offset(1)
Next ws
Set rg = rg.Offset(1)
