ｍａｂｏのｂｌｏｇです。

　在宅でお手伝いをしている仕事関連で、エクセルでの処理を

　手短にやろうと、久しぶりにエクセルのVBAをいじりました。

　やることは、

　　原本
　　↓
　　シートのコピー
　　↓
　　振分してシートごとに転記
　　↓
　　コピーの削除

　これだけですが、０から作ることはできないので、NETと検索

　するとちょうどVBAのプログラムがでていました。

　　　Sub 担当者別に振り分け()
　　　　Dim OrgWS As Worksheet, TmpWS As Worksheet, CurWS As Worksheet
　　　　Dim FromCell As Range
　　　　Dim ToCellNum As Integer
　　　　Dim CurName As String

　　　　'変数初期化
　　　　　　　　Set OrgWS = Worksheets("Sheet1") '元のデータがあるシート名を指定
　　　　　　　　CurName = ""

　　　　'処理終了まで描画を止める
　　　　　　　　Application.ScreenUpdating = False

　　　　'シートを作業用にコピーして担当者でソート
　　　　　　　　OrgWS.Copy after:=Sheets(Worksheets.Count)
　　　　　　　　Set TmpWS = Worksheets(Worksheets.Count)
　　　　　　　　TmpWS.Columns("A:G").Sort Key1:=Range("A2"), Header:=xlYes

　　　　'メイン処理
　　　　　　　For Each FromCell In TmpWS.Range("A2", TmpWS.Range("A65536").End(xlUp))
　　　　　　　　If FromCell.Value <> CurName Then '次の担当者に移った場合
　　　　　　　　　　CurName = FromCell.Value
　　　　　　　　　　Worksheets.Add after:=Worksheets(Worksheets.Count) 'シートを最後に追加
　　　　　　　　　　Set CurWS = Worksheets(Worksheets.Count)
　　　　　　　　　　CurWS.Name = CurName 'シート名を担当者にする
　　　　　　　　　　ToCellNum = 2 'コピー先セルの行番号を初期設定
　　　　　　　　　　OrgWS.Range("B1", "G1").Copy CurWS.Range("A1") 'タイトル行をコピー
　　　　　　　　End If
　　　　　　　　　FromCell.Offset(0, 1).Resize(1, 6).Copy CurWS.Cells(ToCellNum, 1) 'データのコピー
　　　　　　　　　ToCellNum = ToCellNum + 1 'コピー先セルを一つ下に進める
　　　　　　　Next

　　　　'作業用シートを削除
　　　　　　　Application.DisplayAlerts = False
　　　　　　　TmpWS.Delete
　　　　　　　Application.DisplayAlerts = True

　　　　'描画を再開
　　　　　　　Application.ScreenUpdating = True

　でした。すぐ動くかとおもいましたが、エラーでだめでした。

　ネットで検索をしながら、やっと、動くように手直ししました。

　動かなかったのは、多分、掲載してあったVBAは、２００３用の

　古いものだったのかもしれません。２０１３では、動きませんでした。

　下記が、修正して、私の環境で動くようにしたものです。

Sub 振分()
　　Dim OrgWS As Worksheet, TmpWS As Worksheet, CurWS As Worksheet
　　Dim FromCell As Range
　　Dim ToCellNum As Integer
　　Dim CurName As String

　　'変数初期化
　　　　Set OrgWS = Worksheets("一覧") '元のデータがあるシート名を指定
　　　　CurName = ""

　　'処理終了まで描画を止める
　　Application.ScreenUpdating = False

　　'シートを作業用にコピーして担当者でソート
　　　　OrgWS.Copy after:=Sheets(Worksheets.Count)
　　　　Set TmpWS = Worksheets(Worksheets.Count) '最後ワークシートを作業用に
　　　　TmpWS.Activate
　　　　TmpWS.Range("B2:I17").Sort Key1:=TmpWS.Range("C3"), order1:=xlAscending, Header:=xlYes


　　'メイン処理
　　　　For Each FromCell In TmpWS.Range("C3", TmpWS.Range("C" & Rows.Count).End(xlUp))

　　　　　　If FromCell.Value = "終了" Then Exit For

　　　　　　If FromCell.Value <> CurName Then
　　　　　　　　CurName = FromCell.Value
　　　　　　　　Worksheets.Add after:=Worksheets(Worksheets.Count) 'シートを最後に追加
　　　　　　　　Set CurWS = Worksheets(Worksheets.Count)
　　　　　　　　CurWS.Name = CurName 'シート名を種別名にする
　　　　　　　　ToCellNum = 1 'コピー先セルの行番号を初期設定
　　　　　　　　OrgWS.Range("B1", "I2").Copy CurWS.Range("B2") 'タイトル行をコピー
　　　　　　End If

　　　　　　ToCellNum = ToCellNum + 1 'コピー先セルを一つ下に進める
　　　　　　FromCell.Offset(0, -1).Resize(1, 8).Copy CurWS.Cells((ToCellNum + 2), 2) 'データのコピー

　　　　Next

　　'作業用シートを削除
　　　　Application.DisplayAlerts = False
　　　　TmpWS.Delete
　　　　Application.DisplayAlerts = True

　　'描画を再開
　　　　Application.ScreenUpdating = True

End Sub

　　作業シートの作製までは、うまくいったのですが、このシート

　　をソートしようと思っても、原本がソートされ、ここを直すのに

　　まる一日以上かかってしまいました。

　　目が疲れました。