『分類と並び替え』（BOXY）
 過去ログを調べましたが、似たようなものがありましたがアレンジ方法が
 よく分からないので、以下の条件についてそのやり方をご指導願います。

 　　〔A〕　〔B〕  〔C〕　　
  1　名前　　電車　 性別　　
  2  AAA     A　　　 1
  3  BBB     B       2

 職場のレクで旅行に行くのに電車の時間がAとBの２通りあります。
 名前は職場在籍者全員の名簿で１が男性、２が女性です。

 電車のAかBか空欄（不参加）かを確認して入力した後、AとBの結果をそれぞれ別の
 シートに集計して、座席の割り振りのため名前をランダムに並び替えて、女性(2)の
 名前だけ赤字で表示したい。
　
 こんな条件なんですが･･･　
----
 関数で乱数を発生させると再計算の度に変化するので、マクロで書いてみました。
1)フィルタオプションの設定で電車=A,Bで別シートへ抽出
2)別シートのD列に乱数を発生
3)D列基準で並べ替え
4)C列が2の時文字色赤
4)不要列・行をクリア・削除
 こんな感じでしょうか?　　(1/22 10:54部分修正)(Hatch)
Sub Macro1()
Dim lRow As Long, i As Integer
Dim c As Range
Dim sh(2) As Worksheet
Dim myCar(2) As String
Set sh(1) = Worksheets("Sheet2")
Set sh(2) = Worksheets("Sheet3")
myCar(1) = "A"
myCar(2) = "B"
For i = 1 To 2
    With sh(i)
        .Range("A:D").Clear
        .Range("A2") = "=Sheet1!B2=""" & myCar(i) & """"
        lRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
        Sheets("Sheet1").Range("A1:C" & lRow).AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=.Range("A1:A2"), _
            CopyToRange:=.Range("A4"), _
            Unique:=False
        
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
        Randomize
        For Each c In .Range("D5:D" & lRow)
            c.Value = Rnd()
        Next c
        .Range("A4:D" & lRow).Sort Key1:=.Range("D5"), Header:=xlYes
        For Each c In .Range("A5:A" & lRow)
            If c.Offset(0, 2).Value = 2 Then
                c.Font.ColorIndex = 3
            End If
        Next c
        .Range("D:D").Clear
        .Range("1:3").Delete
    End With
Next i
End Sub


----
 Hatchさん、返事が遅くなりました。ありがとうございます。
 もうひとつ教えて下さい。
 連絡先を忘れていたので、B列に携帯番号を追加したい
 のですが、A：名前、B:携帯番号、C：電車、D:性別という構成に変更したら、
 どうなりますか？
----
 こんな感じになります。(Hatch)
Sub Macro1()
Dim lRow As Long, i As Integer
Dim c As Range
Dim sh(2) As Worksheet
Dim myCar(2) As String
Set sh(1) = Worksheets("Sheet2")
Set sh(2) = Worksheets("Sheet3")
myCar(1) = "A"
myCar(2) = "B"
    For i = 1 To 2
        With sh(i)
            .Range("A:E").Clear
            '---フィルタオプションの設定の条件式をA2に入力
            .Range("A2") = "=Sheet1!C2=""" & myCar(i) & """"
            lRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
            '---フィルタオプションの設定でAまたはBをSheet2(sh(1)）またはSheet3(sh(2))へ抽出
            Sheets("Sheet1").Range("A1:D" & lRow).AdvancedFilter Action:=xlFilterCopy, _
                CriteriaRange:=.Range("A1:A2"), _
                CopyToRange:=.Range("A4"), _
                Unique:=False
            lRow = .Range("A" & Rows.Count).End(xlUp).Row
            '---乱数をE列へ入力
            Randomize
            For Each c In .Range("E5:E" & lRow)
                c.Value = Rnd()
            Next c
            '---E列を基準に並べ替え
            .Range("A4:E" & lRow).Sort Key1:=.Range("E5"), Header:=xlYes
            '---C列が2の時、文字色を赤に設定
            For Each c In .Range("A5:A" & lRow)
                If c.Offset(0, 3).Value = 2 Then
                    c.Font.ColorIndex = 3
                End If
            Next c
            '---E列をクリア、1〜3行目を削除
            .Range("E:E").Clear
            .Range("1:3").Delete
        End With
    Next i
End Sub

----
 Hatchさん、ありがとうございました。（BOXY)
 申し訳ありませんが、マクロと1)〜5)について解説してもらえませんか？
 1)フィルタオプションの設定で電車=A,Bで別シートへ抽出
 2)別シートのD列に乱数を発生
 3)D列基準で並べ替え
 4)C列が2の時文字色赤
 5)不要列・行をクリア・削除
----
 上記マクロのコード内にそれぞれの説明を追記しておきます。(Hatch)

----
 Hatchさん、ありがとうございます。（BOXY)
 よく出てくるRangeの使い方について以下のマクロを例にもう少し詳しく
 説明して頂けませんか？馴染みがないので、応用が効きません。
 お手数ばかりかけますが、よろしくお願いします。

 '---フィルタオプションの設定でAまたはBをSheet2(sh(1)）またはSheet3(sh(2))へ抽出
 Sheets("Sheet1").Range("A1:D" & lRow).AdvancedFilter Action:=xlFilterCopy, _
   CriteriaRange:=.Range("A1:A2"), _
   CopyToRange:=.Range("A4"), _
   Unique:=False
   lRow = .Range("A" & Rows.Count).End(xlUp).Row

----
 最初のlRowはSheet1の最終行、この部分はsh(i)が指定してあるので、sh(1)=Sheet2の時を書きます。
 Sheet1のA1〜D列最終行のセル範囲へAdvancedFilterをかけます。
 Action:=xlFilterCopyはリスト範囲とは他の場所に抽出データをコピーします。
 CriteriaRange:検索条件範囲を指定しています。
 　　Sheet2のA1:A2を指定しています。なお、A1は未使用、A2へは上の方で条件式を入力しています。
 CopyToRange：抽出した行のコピー先のセル範囲を指定しています。
 　　Sheet2のA4をコピー先に指定しています。
 Unique=True=Falseは重複するレコードも含めて、検索条件に一致するレコードがすべて抽出されます。

 lRow = .Range("A" & Rows.Count).End(xlUp).Row
 ここでは、Sheet2の最終行(抽出データの最終行)をlRowに代入しています。
 lRowは前にも使用していますが、ここで値が書き換えられています。
 本当は変数名をlRow2などとして区別した方がいいのかもしれませんが、面倒でしたので流用しています。
 
 以上でよろしいでしょうか？　　(Hatch)

----
 Hatchさん、いつもいつもありがとうございます。（BOXY)
 自分でも問題を考えて、応用できるように頑張ってみます。
 今後ともよろしくお願いします。
----
 Hatchさん、昨日の解説から自分なりに応用（展開）を考えていますが
 上手くいきません。（BOXY)
 
 応用例として以下の３つのパターンにトライしました｡
 1.sheet1の表がA1:D3ではなく、B3:E5の場合
 2.shhet2への抽出がA1:D3ではなく、C3:F5の場合
 3.電車がAとBではなく、アとイの場合
 時間だけが過ぎてしまって、１つもクリアできそうにありません。
 
 基本的なＶＢＡプログラミングが理解できていないためですが、
 入門書としてのお奨めがあれば、紹介して下さい。
----
 Sheet1にはB3からD5にデータが（３列ですわなぁ？）入っとるとして、Sheet2のC列E
 列に拾うマクロですワ。
 試してみてくらはい。
 　　　　　　　（弥太郎）
 '----------------------------
 Option Explicit
Sub boxy()
    Dim dic As Object, i As Long, y As Long, m As Integer, s As Integer
    Dim w As Integer, tbl, x, t
    
    Application.ScreenUpdating = False
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
        tbl = .Range("b2").Resize(.Range("b" & Rows.Count).End(xlUp).Row, 3)
    End With
    ReDim densya(1 To 2)
    For i = 1 To UBound(tbl, 1)
        If Not IsEmpty(tbl(i, 2)) Then
            If Not dic.exists(tbl(i, 2)) Then
                y = y + 1
                densya(y) = tbl(i, 2)
                dic(tbl(i, 2)) = Empty
                If y = 2 Then Exit For
            End If
        End If
    Next i
    ReDim x(1 To UBound(tbl, 1), 1 To 3)
    ReDim t(1 To UBound(tbl, 1), 1 To 3)
    For i = 1 To UBound(tbl, 1)
        If Not IsEmpty(tbl(i, 2)) Then
            If tbl(i, 2) = densya(1) Then
                m = m + 1
                x(m, 1) = tbl(i, 1)
                x(m, 2) = tbl(i, 3)
                x(m, 3) = Int(Rnd * 10000)
            Else
                w = w + 1
                t(w, 1) = tbl(i, 1)
                t(w, 2) = tbl(i, 3)
                t(w, 3) = Int(Rnd * 10000)
            End If
        End If
    Next i
    With Sheets("sheet2")
        .Cells.Clear
        .Cells.Font.ColorIndex = 0
        .Cells(2, 3).Resize(m, 3) = x
        .Cells(2, 7).Resize(w, 3) = t
        .Cells(2, 3).Resize(m, 3).Sort key1:=.Cells(2, 5)
        .Cells(2, 7).Resize(w, 3).Sort key1:=.Cells(2, 9)
        s = IIf(m > w, m, w)
        For i = 2 To s + 1
            If .Cells(i, 4) = 2 Then .Cells(i, 3).Font.ColorIndex = 3
            If .Cells(i, 8) = 2 Then .Cells(i, 7).Font.ColorIndex = 3
        Next i
            .Cells(1, 8).Resize(s + 1, 2).Delete: .Cells(1, 4).Resize(s + 1, 2).Delete
            .Cells(1, 3) = densya(1): .Cells(1, 5) = densya(2)
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
 End Sub

 
----
 弥太郎さん
 ありがとうございました。（BOXY）
----
 この過去ログを参考に100個のデータを使って実際にマクロを走らせてみたのですが、
 古いパソコン（８年前のものWin98、ｴｸｾﾙ2000）では５分くらいかかってしまいました。
 それまでは、WinXPとｴｸｾﾙ2003のため気にならなかったのですが。
 
 特に
 1)フィルタオプションの設定で電車=A,Bで別シートへ抽出
 2)別シートのD列に乱数を発生
 3)D列基準で並べ替え
 4)C列が2の時文字色赤
 5)不要列・行をクリア・削除
 のうちの2)と3)に時間を取られてしまうようです。
　
 処理時間が半減できるようなマクロに変更はできますか？
 もしくは数式で同様なことができませんか？
 古いパソコンの所有者から「マクロが遅い」（当然？）と言われているので。
（BOXY）

----
 試したわけでもないですが、弥太郎さんのデクチョナリでも遅かったのでしょうか。

 （川野鮎太郎）
----
 弥太郎さんのデクチョナリでは未だ確認できていません。
 確認してみます。（BOXY)
----
 あれっ、これって、ええアイディアが有っても試しても貰われへんっちゅう事でんなぁ（笑
 なんとなく無駄足踏んだみたい・・・、メモメモ。（笑
 　　　　（弥太郎） 
----
 弥太郎さん、ゴメンナサイ。(BOXY)

 エラーが出てそこで止まってしまいました。
 実行時エラー'1004'：
 「アプリケーション定義またはオブジェクト定義のエラーです。」
  With Sheets("sheet2")
        .Cells.Clear
        .Cells.Font.ColorIndex = 0
        .Cells(2, 3).Resize(m, 3) = x
     → .Cells(2, 7).Resize(w, 3) = t
        .Cells(2, 3).Resize(m, 3).Sort key1:=.Cells(2, 5)
        .Cells(2, 7).Resize(w, 3).Sort key1:=.Cells(2, 9)
        s = IIf(m > w, m, w)
        For i = 2 To s + 1
----
 Sheet1の構成がちゃいまんなぁ。
 	A	B	         C	D
 1		名前		
 2		山田　太郎	あ	1
 3		小宮　悦治	あ	1
 4		斉藤　シマ子	い	2
 5		野中　和郎	い	2
 6		野村　英紀	あ	1
 7		嵐　寛寿郎	い	1
 8		斉藤　フキ	あ	1
 9		田中　絹子	い	2
10		田中　真紀子	あ	2
 とこんな塩梅とちゃいますん？
 　　　　　　　（弥太郎）
----
 弥太郎さん
 >A：名前、B:携帯番号、C：電車、D:性別という構成に変更したら･･･
 で確認しました。
 現状のsheet1のレイアウトは、７行目が項目で８行目からデータ入って、
 F:名前、G:電車、H:部署、I:携帯番号、J:性別になっています。(BOXY)
----
 ほなら、かういう事でっか？
 Sheet2のC列E列１行目から抽出しとります。
 　　　　（弥太郎）
 Sub boxy2()
    Dim dic As Object, i As Long, y As Long, m As Integer, s As Integer
    Dim w As Integer, tbl, x, t

    Application.ScreenUpdating = False
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
        tbl = .Range("f8").Resize(.Range("f" & Rows.Count).End(xlUp).Row - 7, 5)
    End With
    ReDim densya(1 To 2)
    For i = 1 To UBound(tbl, 1)
        If Not IsEmpty(tbl(i, 2)) Then
            If Not dic.exists(tbl(i, 2)) Then
                y = y + 1
                densya(y) = tbl(i, 2)
                dic(tbl(i, 2)) = Empty
                If y = 2 Then Exit For
            End If
        End If
    Next i
    ReDim x(1 To UBound(tbl, 1), 1 To 3)
    ReDim t(1 To UBound(tbl, 1), 1 To 3)
    For i = 1 To UBound(tbl, 1)
        If Not IsEmpty(tbl(i, 2)) Then
            If tbl(i, 2) = densya(1) Then
                m = m + 1
                x(m, 1) = tbl(i, 1)
                x(m, 2) = tbl(i, 5)
                x(m, 3) = Int(Rnd * 10000)
            Else
                w = w + 1
                t(w, 1) = tbl(i, 1)
                t(w, 2) = tbl(i, 5)
                t(w, 3) = Int(Rnd * 10000)
            End If
        End If
    Next i
    With Sheets("sheet2")
        .Cells.Clear
        .Cells(2, 3).Resize(m, 3) = x
        .Cells(2, 7).Resize(w, 3) = t
        .Cells(2, 3).Resize(m, 3).Sort key1:=.Cells(2, 5)
        .Cells(2, 7).Resize(w, 3).Sort key1:=.Cells(2, 9)
        s = IIf(m > w, m, w)
        For i = 2 To s + 1
            If .Cells(i, 4) = 2 Then .Cells(i, 3).Font.ColorIndex = 3
            If .Cells(i, 8) = 2 Then .Cells(i, 7).Font.ColorIndex = 3
        Next i
            .Cells(1, 8).Resize(s + 1, 2).Delete: .Cells(1, 4).Resize(s + 1, 2).Delete
            .Cells(1, 3) = "電車:" & densya(1): .Cells(1, 5) = "電車:" & densya(2)
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
 End Sub

----
 弥太郎さん
 ありがとうございます。
 
 今日は時間がないので、検証は夜になります。（スミマセン）
 もうひとつ厄介な条件が追加になりました。

 不参加（空欄）から参加に変更する人が出た場合（電車のア or イになる）、
 既に並び替えまで完成しているsheet2（アの場合）またはsheet3（イの場合）の
 最終行の次の行にsheet1のデータ（名前、部署、携帯番号、性別）を追加したい。
 
 レクの幹事も大変です。よろしくお願いします。（BOXY)
---
 レクと言うても年にそう何度も行きまへんやろ？、それで処理時間が遅い等とクレーム
 を付けられるとはにわかに信じがたいですなぁ。
 わたしゃてっきり旅行会社で使うマクロやと思うとりましたが・・・。
 それはともかく、性別まで拾うのなら何で処理時間のかかる色を付けますのん？色付け
 するなら性別欄は不要と思いますけどなぁ。
 試してくらはい。前述したようにSheet2に拾い出します。
 それと追加したデータの色付けまでは考えとりまへん。
 　　　　（弥太郎）
 '------------
 Sub boxy2()
    Dim dic As Object, i As Long, y As Long, m As Integer, s As Integer
    Dim w As Integer, j As Integer, tbl, x, t

    Application.ScreenUpdating = False
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
        tbl = .Range("f8").Resize(.Range("f" & Rows.Count).End(xlUp).Row - 7, 5)
    End With
    ReDim densya(1 To 2)
    For i = 1 To UBound(tbl, 1)
        If Not IsEmpty(tbl(i, 2)) Then
            If Not dic.exists(tbl(i, 2)) Then
                y = y + 1
                densya(y) = tbl(i, 2)
                dic(tbl(i, 2)) = Empty
                If y = 2 Then Exit For
            End If
        End If
    Next i
    ReDim x(1 To UBound(tbl, 1), 1 To 6)
    ReDim t(1 To UBound(tbl, 1), 1 To 6)
    For i = 1 To UBound(tbl, 1)
        If Not IsEmpty(tbl(i, 2)) Then
            If tbl(i, 2) = densya(1) Then
                m = m + 1
                For j = 1 To 6
                    If j = 6 Then
                        x(m, j) = Int(Rnd * 10000)
                    ElseIf j <> 2 Then
                        x(m, j) = tbl(i, j)
                    End If
                Next j
            Else
                w = w + 1
                For j = 1 To 6
                    If j = 6 Then
                        t(w, j) = Int(Rnd * 10000)
                    ElseIf j <> 2 Then
                        t(w, j) = tbl(i, j)
                    End If
                Next j
            End If
        End If
    Next i
    With Sheets("sheet2")
        .Cells.Clear
        .Cells(2, 3).Resize(m, 6) = x
        .Cells(2, 9).Resize(w, 6) = t
        .Cells(2, 3).Resize(m, 6).Sort key1:=.Cells(2, 8)
        .Cells(2, 9).Resize(w, 6).Sort key1:=.Cells(2, 14)
        s = IIf(m > w, m, w)
        For i = 2 To s + 1
            If .Cells(i, 7) = 2 Then .Cells(i, 3).Font.ColorIndex = 3
            If .Cells(i, 13) = 2 Then .Cells(i, 9).Font.ColorIndex = 3
        Next i
            .Cells(1, 14).Resize(s + 1).Delete: .Cells(1, 10).Resize(s + 1).Delete
            .Cells(1, 8).Resize(s + 1).Delete: .Cells(1, 4).Resize(s + 1).Delete
            .Cells(1, 3) = "電車:" & densya(1): .Cells(1, 7) = "電車:" & densya(2)
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
 End Sub
 '-----------------------------
 Sub 追加()
    Dim dic As Object, mx_1 As Long, mx_2 As Long, mx As Long, i As Long
    Dim m As Integer, w As Integer, x, t, tbl, data_1
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet2")
        mx_1 = .Cells(Rows.Count, 3).End(xlUp).Row
        mx_2 = .Cells(Rows.Count, 7).End(xlUp).Row
        mx = IIf(mx_1 > mx_2, mx_1, mx_2)
        tbl = .Cells(2, 3).Resize(mx - 1, 8)
        data_1 = Split(.Cells(1, 3), ":")(1)
        
        For i = 1 To UBound(tbl, 1)
            If Not IsEmpty(tbl(i, 1)) Then dic(tbl(i, 1)) = Empty
            If Not IsEmpty(tbl(i, 1)) Then dic(tbl(i, 5)) = Empty
        Next i
    End With
    With Sheets("sheet1")
        tbl = .Range("f8").Resize(.Range("f" & Rows.Count).End(xlUp).Row - 7, 5)
    End With
    ReDim x(1 To UBound(tbl, 1), 1 To 4)
    ReDim t(1 To UBound(tbl, 1), 1 To 4)
    For i = 1 To UBound(tbl, 1)
        If Not dic.exists(tbl(i, 1)) And Not IsEmpty(tbl(i, 2)) Then        
             If tbl(i, 2) = data_1 Then
                m = m + 1
                x(m, 1) = tbl(i, 1)
                x(m, 2) = tbl(i, 3)
                x(m, 3) = tbl(i, 4)
                x(m, 4) = tbl(i, 5)
            Else
                w = w + 1
                t(w, 1) = tbl(i, 1)
                t(w, 2) = tbl(i, 3)
                t(w, 3) = tbl(i, 4)
                t(w, 4) = tbl(i, 5)
            End If
        End If
    Next i
    With Sheets("sheet2")
        If m > 0 Then
            .Cells(mx_1 + 1, 3).Resize(m, 4) = x
        End If
        If w > 0 Then
            .Cells(mx_2 + 1, 7).Resize(w, 4) = t
        End If
    End With
    Set dic = Nothing
 End Sub
 不具合発見　しゅうせぇ 12:43

----
 弥太郎さん
 只々感激しています。速いし、綺麗だし・・・。(BOXY)

 どこの会社にもいますよね、文句と注文だけはしっかり言う人！
 レクの幹事は百方美人を求められます。本当にありがとうございました。

 是非、電車だけでなくレク先のオプションにも使いたいので
 ご協力の程よろしくお願いします。
 
 オプション１（午前）とオプション２（午後）があって、両方とも参加、
 両方とも不参加（空欄）、１だけ、２だけの４つの選択肢の中で１を
 選んだ人のグループと２を選んだ人のグループで各々名前をランダムに
 並び替えてたい。後から気が変わった人のために、１と２のソート後の
 最終行の次の行に追加ができるようにしたい。男女の色分けはやめます。
 
  F:名前、G:オプション、H:部署、I:携帯番号、J:性別です。
----
 今のマクロの一部をいじれば叶うと思いまっせぇ。
 例えば
 >.Cells(1, 3) = "電車:" & densya(1): .Cells(1, 7) = "電車:" & densya
 は、.cells(1,3)="午前":.cells(1,7)="午後"にし、
 最初のFor i〜Next iは不要でっしゃろから削除
 >       If Not IsEmpty(tbl(i, 2)) Then
            If tbl(i, 2) = densya(1) Then
 >   if not isempty(tbl(i,2)) then
          if tbl(i,2)="午前" or tbl(i,2)="両方"
     else を end if　で一旦切ってしもうて
　　if tbl(i,2)="午後" or tbl(i,2)="両方" then
    みたいに書き換えればいけまっしゃろ？
 　　　　　（弥太郎）

 
----
 弥太郎さん
　
 マクロのいじり方がわかりません。。(BOXY)

 >.Cells(1, 3) = "電車:" & densya(1): .Cells(1, 7) = "電車:" & densya
 >       If Not IsEmpty(tbl(i, 2)) Then
 この２つの文は見つかりましたが

 >   if not isempty(tbl(i,2)) then
 が見つかりません。
----
 難儀な御方でんなぁ（笑
 いちいち説明しとると長引くんで作り変えましたワ。
 　　　　　　（弥太郎）
 '-------------------
 Sub boxy3()
    Dim dic As Object, i As Long, y As Long, m As Integer, s As Integer
    Dim w As Integer, j As Integer, tbl, x, t

    Application.ScreenUpdating = False
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
        tbl = .Range("f8").Resize(.Range("f" & Rows.Count).End(xlUp).Row - 7, 5)
    End With
    ReDim x(1 To UBound(tbl, 1), 1 To 6)
    ReDim t(1 To UBound(tbl, 1), 1 To 6)
    For i = 1 To UBound(tbl, 1)
        If Not IsEmpty(tbl(i, 2)) Then
            If tbl(i, 2) = "午前" Or tbl(i, 2) = "両方" Then
                m = m + 1
                For j = 1 To 6
                    If j = 6 Then
                        x(m, j) = Int(Rnd * 10000)
                    ElseIf j <> 2 Then
                        x(m, j) = tbl(i, j)
                    End If
                Next j
            End If
            If tbl(i, 2) = "午後" Or tbl(i, 2) = "両方" Then
                w = w + 1
                For j = 1 To 6
                    If j = 6 Then
                        t(w, j) = Int(Rnd * 10000)
                    ElseIf j <> 2 Then
                        t(w, j) = tbl(i, j)
                    End If
                Next j
            End If
        End If
    Next i
    With Sheets("sheet2")
        .Cells.Clear
        .Cells(2, 3).Resize(m, 6) = x
        .Cells(2, 9).Resize(w, 6) = t
        .Cells(2, 3).Resize(m, 6).Sort key1:=.Cells(2, 8)
        .Cells(2, 9).Resize(w, 6).Sort key1:=.Cells(2, 14)
        s = IIf(m > w, m, w)
            .Cells(1, 14).Resize(s + 1).Delete: .Cells(1, 10).Resize(s + 1).Delete
            .Cells(1, 8).Resize(s + 1).Delete: .Cells(1, 4).Resize(s + 1).Delete
            .Cells(1, 3) = "午前": .Cells(1, 7) = "午後"
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
 End Sub
 '----------------------------------
 Sub 追加1()
    Dim dic As Object, mx_1 As Long, mx_2 As Long, mx As Long, i As Long
    Dim m As Integer, w As Integer, x, t, tbl
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet2")
        mx_1 = .Cells(Rows.Count, 3).End(xlUp).Row
        mx_2 = .Cells(Rows.Count, 7).End(xlUp).Row
        mx = IIf(mx_1 > mx_2, mx_1, mx_2)
        tbl = .Cells(2, 3).Resize(mx - 1, 8)
        
        For i = 1 To UBound(tbl, 1)
            If Not IsEmpty(tbl(i, 1)) Then dic(tbl(i, 1)) = Empty
             'If Not IsEmpty(tbl(i, 1)) Then dic(tbl(i, 5)) = Empty
            '↓に変更
            If Not IsEmpty(tbl(i, 5)) Then dic(tbl(i, 5)) = Empty
       
　　　　Next i
    End With
    With Sheets("sheet1")
        tbl = .Range("f8").Resize(.Range("f" & Rows.Count).End(xlUp).Row - 7, 5)
    End With
    ReDim x(1 To UBound(tbl, 1), 1 To 4)
    ReDim t(1 To UBound(tbl, 1), 1 To 4)
    For i = 1 To UBound(tbl, 1)
        If Not dic.exists(tbl(i, 1)) And Not IsEmpty(tbl(i, 2)) Then
            If tbl(i, 2) = "午前" Or tbl(i, 2) = "両方" Then
                m = m + 1
                x(m, 1) = tbl(i, 1)
                x(m, 2) = tbl(i, 3)
                x(m, 3) = tbl(i, 4)
                x(m, 4) = tbl(i, 5)
            End If
            If tbl(i, 2) = "午後" Or tbl(i, 2) = "両方" Then
                w = w + 1
                t(w, 1) = tbl(i, 1)
                t(w, 2) = tbl(i, 3)
                t(w, 3) = tbl(i, 4)
                t(w, 4) = tbl(i, 5)
            End If
        End If
    Next i
    With Sheets("sheet2")
        If m > 0 Then
            .Cells(mx_1 + 1, 3).Resize(m, 4) = x
        End If
        If w > 0 Then
            .Cells(mx_2 + 1, 7).Resize(w, 4) = t
        End If
    End With
    Set dic = Nothing
 End Sub




----
 弥太郎さん
 また難儀掛けます。(BOXY)

 boxy3を実行したら、エラーが出てそこで止まってしまいました。
 実行時エラー'1004'：
 「アプリケーション定義またはオブジェクト定義のエラーです。」
  With Sheets("sheet2")
        .Cells.Clear
     → .Cells(2, 3).Resize(m, 6) = x
      　.Cells(2, 9).Resize(w, 6) = t
        .Cells(2, 3).Resize(m, 6).Sort key1:=.Cells(2, 8)
        .Cells(2, 9).Resize(w, 6).Sort key1:=.Cells(2, 14)
        s = IIf(m > w, m, w)
----
 Ｇ列８行目から下の方向へ午前、午後、両方などと入力されとりまっか？
 　　　　（弥太郎）

       
----
 弥太郎さん

 ご指摘通り、sheet1がAとBのままになっていました。
 午前、午後、両方と再入力したら、解決しました。
 本当にありがとうございました。(BOXY)

----
 弥太郎さん、ヘルプです。
 
 午前、午後、両方の３つの選択で、全員が「午前」もしくは「午後」を
 選択するとエラーが発生することが判明しました。
 全員が「両方」ならＯＫです。(BOXY)
---- 
 On Error Resume Next
 With Sheets("Sheet2")'この行の上に↑を追加
 
 Application.ScreenUpdating = True 'この行の下に↓を追加
 On Error GoTo 0

 で、全て上手くいくと思いまっせぇ。
    　　　　　（弥太郎）

 

----
 弥太郎さん、ありがとうございました。（BOXY）

----
 弥太郎さん、またしてもヘルプです。(BOXY)
 
 実践モードに入って苦労しています。
 なんどもやってみましたが、追加1()のマクロを使って、午前または
 両方では午前のみ追加され、午後または両方で午後には追加されません。

----
 ＞弥太郎さん、またしてもヘルプです。(BOXY)

　だいたいVBA少しは解ってるのか？

 ＞どこの会社にもいますよね、文句と注文だけはしっかり言う人！

　あんただろ？
　金払ってどっかに頼め。



----
 スミマセン･･･(BOXY)
----
 最近秘匿性をええことに、暴言を吐く輩が目立ちまんなぁ。些か憤りをおぼえますわ。
 BOXYさん、HNも書けない連中の暴言は無視しまひょ。
 ところで、上の件、訂正しときましたんで、試してみてくらはい。
 一ヶ所怪しいところがありました（汗
 　　　　（弥太郎）