カテゴリー: ＶＢＡ

　お手伝いでしている仕事の内容は、ある行事の参加者申し
　込みの受付の処理です。
　参加希望者は、ＨＰから申し込みをします。すると。手元に
　申し込みのメールが届きます。
　このメールを処理して、

　　１　受講票返信メールの作成・送付
　　　　　受付日付
　　　　　受付Ｎｏ
　　２　受講者一覧表の作成

　の一連の作業をします。以前は、この作業を全部手作業
　でやってました。
　今回の催しの定員が１００名ですから、結構な手間です。
　そこで、ＶＢＡの登場でしたが、やっと次のような手順で
　かなりの部分を半自動？にすることができました。

　
　　送られてくる自動返信メールのコピー(手動）
　　　↓
　　エクセルに貼り付け（手動）
　　　↓
　　必要データーの取り出しと成形（エクセル関数）
　　　↓
　　一覧表への追加（エクセルＶＢＡ）
　　　↓
　　返信文面の作製（エクセル関数）
　　　　受付月日の挿入
　　　　受付Ｎｏの挿入
　　　↓
　　エクセルの返信文面のコピー（手動）
　　　↓
　　メールへの貼り付け（手動）
　　　↓
　　送信・・・・・・・・・受付完了

　これらの作業のなかで、一覧表への追加が一番てまどりまし
　た。
　その次にてまどったのが受付Ｎｏの挿入です。
　これは、受付名簿の一覧表から、追加した項目のＮｏを
　読みとることで実現しました。

　　　Worksheets(“Sheet1”).Range(“B” & Range(“C4”).-
　　　　　　　　End(xlDown).Row).Copy
　　　Range(“J6”).Select
　　　ActiveSheet.Paste

　　表に追加すると、Ｃ４の表題以下のセルに種別が追加され
　ますので、

　　　Range(“C4”).End(xlDown).Row)

　で、どこのセルが記入済みの最下段（行）か取得します。
　この読みとった行とＮｏの書いてある”Ｂ”と＆をとって、
　該当のＮｏのセルの番地を作ってます。

　Worksheets(“Sheet1”).Range(“B” & Range(“C4”).End(xlDown).Row)

　これを、作業セルのＪ６にペーストします。

　　　Range(“J6”).Select
　　　ActiveSheet.Paste

　こんな一連の動作で、受付Ｎｏを挿入した文面を作りました。
　手間取りましたが、ちょっと楽になって、間違いもすくなくなり
　そうです。

　手強いＶＢＡを少しやっつけました。
　以前にしたことを少し思いだしましたが、未だ手強いのには、
　変わりありません。
　昨日、やっつけたのは、一定の範囲のセルを表の最下行に
　追加でペーストするというものです。
　ただ、これだけで、何時間もかかりました。できてみると、

　Sub コピー()
　　　　Worksheets(“Sheet1”).Range(“K133:O133”).Copy
　　　　Worksheets(“Sheet1”).Range(“C” & （Range(“C4”).End(xlDown).Row + 1）).-
　　　　PasteSpecial Paste:=xlPasteValues, -
　　　　Operation:=xlNone, SkipBlanks:=False, Transpose:=False
　　End Sub

　何のことはない、たった、２行です。
　K133～O133のセルに書かれているセルの値だけを、表の
　最下行にコピーするだけです。
　
　表の最下行を

　　　Range(“C4”).End(xlDown).Row

　で求め、その下を＋１で求めます。
　エクセルの番地は、英語と数字です。この番地を

　　　Range(“C” & （Range(“C4”).End(xlDown).Row + 1）)

　で＆を使って作ります。
　
　

　在宅でお手伝いをしている仕事関連で、エクセルでの処理を
　手短にやろうと、久しぶりにエクセルの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

　　作業シートの作製までは、うまくいったのですが、このシート
　　をソートしようと思っても、原本がソートされ、ここを直すのに
　　まる一日以上かかってしまいました。
　　目が疲れました。