在宅でお手伝いをしている仕事関連で、エクセルでの処理を
手短にやろうと、久しぶりにエクセルの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
作業シートの作製までは、うまくいったのですが、このシート
をソートしようと思っても、原本がソートされ、ここを直すのに
まる一日以上かかってしまいました。
目が疲れました。