tatsu99様 昨日は「VBAシフト表における従業員の固定休のプログラムについて」の件ありがとうございました。
従業員の休みに対応したVBAプログラム、活用させていただいております。
昨日の今日で大変申し訳ないのですが、今回の質問は勤務管理表の休み以外のセルに、設定シートにある従業員の担当業務を勤務管理表シートに割り振りするプログラムについてご教示頂きたく質問致しました。

添付した画像を例に構築したいVBAプログラムをご説明させていただきます。
日にちは14日から一ヶ月とします。
上段の設定シートと下段の勤務管理表シートは同じExcelファイルになります。キャプチャする為に分割致しました。
設定シートの表は各従業員の担当業務になります。
それを勤務管理表の「休」以外のセルに優先1の業務をそれぞれの担当者に出力。
一日の業務には必ず「会議」、「事務」、「営業」を組み込みます。
14日を例としますと「営業」担当のCさんが休みの為、Eさんが「営業」担当になります。
17日は「会議」担当のBさんがお休みの為、Aさんが「会議」担当になります。
この様に「休」のセル以外に、担当常務を割り振るプログラムとその担当者が休みの場合に違う担当者が変わりを勤めるプログラムを作成したい内容になります。
また文字の色の条件を「サポート」は赤、「会議」は緑、「営業」は黄色、「事務」は水色と設定をしたいです。
勤務管理表の休みの関係で担当業務の「会議」、「営業」、「事務」を出力した際に重複があった場合はMsgBoxで「重複があります!」のメッセージを。また背景を赤で表示させたいです。

以上が私が構築したいプログラムの内容になります。

tatsu99様 よろしくお願い致します。

「tatsu99様 VBA勤務管理表の業務」の質問画像

質問者からの補足コメント

  • tatsu99様、設定シートの各従業員担当業務の表の最新キャプチャ画像を添付致しましたのでこれを例にお礼からご説明致します。

    「tatsu99様 VBA勤務管理表の業務」の補足画像1
    No.5の回答に寄せられた補足コメントです。 補足日時:2017/05/15 12:05

A 回答 (18件中11~18件)

追加確認です。


「ヘルプ」に関しては、他の業務ができないので、「ヘルプ」を設けたとのことですので、
ヘルプが定義される場合は、優先1にヘルプを定義し、優先2から優先4は全て空白ということに
したいのですが、いかがでしょうか。
もし、その新人が、サポートとかの他の業務ができるようになれば、ヘルプを削除し、サポート等の業務を記述することになります。
    • good
    • 0
この回答へのお礼

tatsu99様、要件の変更に関して誠に申し訳ございません。
この様なことを繰り返さない様に、以後、気をつけます。

1)提示例でBさん1人体制のとき、割り当ては会議で間違いないですか。
 ・はい、間違いありません。
2)Dさんが優先1=事務、優先2=会議で定義されているなら、
  Dさん1人体制のとき、割り当ては、事務で間違いないですか。
 ・はい、間違いありません。

一人体制、二人体制の時の業務の割り当てに「会議」、「事務」を優先の件ですが、
担当業務がない場合はそのまま入力なし、とする事が可能であれば以下の様にしたいです。
1)提示例でCさん1人体制のとき、何の業務を割り当てるのか?
  Cさん一人体制の場合は「会議」、「事務」の中の優先2の「会議」が出来るので「会議」。
2)提示例でBさんとCさんの2人体制のとき、BさんとCさんは何の業務をわりあてるのか?
  Bさんは「会議」、Cさんは「事務」が出来ないので何も入力無し。
3)提示例でAさんとCさんの2人体制のとき、AさんとCさんは何の業務をわりあてるのか?
  AさんはCさんには出来ない優先3にある「事務」が出来るので「事務」。Cさんは優先2の「会議」。
4)提示例でEさんとCさんの2人体制のとき、EさんとCさんは何の業務をわりあてるのか?
  Eさんはそのまま入力なしの、Cさんは「会議」。
上記の「会議」、「事務」に該当しない場合の処理をそのまま片方、無視するなどの処理は可能でしょうか?

はい、「ヘルプ」は優先1に定義し優先2から4は空白で問題ありません。

tatsu99様何か良い方法はありますでしょうか?

よろしくお願い致します。

お礼日時:2017/05/15 13:52

追加確認です。


1人体制で会議と事務は優先順位はないと考えてよいですか。
1)提示例でBさん1人体制のとき、割り当ては会議で間違いないですか。
2)Dさんが優先1=事務、優先2=会議で定義されているなら、
  Dさん1人体制のとき、割り当ては、事務で間違いないですか。
    • good
    • 0

要件が変わりすぎます。


・「ヘルプ」業務がいきなり出現している。
・1人体制では、会議か事務を割り当てるということだったが「ヘルプ」がある。
・各担当者は、サポート、営業、事務、会議のいずれもできるはずであるが、出来なくなっている。
等があります。
最初に要件を全て提示されることを望みます。今回は、やむなしとしますが、次回からの対応はなしと思ってください。

不明点は以下の通りです。
1人体制、2人体制で、会議、事務を優先とあるが、そのことに関してです。
1)提示例でCさん1人体制のとき、何の業務を割り当てるのか?
2)提示例でBさんとCさんの2人体制のとき、BさんとCさんは何の業務をわりあてるのか?
3)提示例でAさんとCさんの2人体制のとき、AさんとCさんは何の業務をわりあてるのか?
4)提示例でEさんとCさんの2人体制のとき、EさんとCさんは何の業務をわりあてるのか?
    • good
    • 0

確認の追加です。


確認5
専従要員の割り当ては、その専従要員の優先1の業務が必ず割り当てられる。他の業務をすることは一切ない。
但し、1人体制で、営業の専従要員がついたときは、会議か事務の何れかを割り当てる。
従って、専従要員間で業務の持ち回りのようなことはしない。
持ち回りをする場合は、次の月に、設定シートの優先1の業務を変えることにより行う。

確認6
サポート要員を会議、事務、営業の何れかに割り当てる場合は、設定シートの従業員名が上位(行番号の小さいほう)に
あるものから、割り当てを行う。提示された例では、Aさん、Eさん、Fさんがサポート要員なので
A→E→Fの順に割り当てる。
従ってFさんが新人なら、「サポート」を行う確率が最も高くなる。
もし、新人を優先的に会議、事務、営業の何れかに割り当てたいなら、Aさんの位置に新人を持ってくることが必要となる。
尚、サポート要員の割り当て順序は、設定シートの並びで決まり、勤務管理表シートの並びとは関係しない。
(設定シートの要員の並びと勤務管理表シートの並びは一致しなくても良い)
この回答への補足あり
    • good
    • 0
この回答へのお礼

各従業員の担当業務は設定シートの様に担当業務が出来る人、出来ない人がおります。
補足添付画像を例にBさんは「会議」、「事務」は出来るが「営業が」出来ない。
Cさんは「営業」、「会議」は出来るが「事務」が出来ない。
この設定シートを条件に勤務管理表に出力をしたいです。
例えば月曜日は全員出勤なので優先1からそのまま割り当て。
火曜日はBさんがお休みの為「会議」担当にAさん、CさんがおりますがCさんが優先1の「営業」の為Aさん。
水曜日は「営業」担当のCさんがお休みの為優先2からDさんが担当でAさんが「事務」。
木曜日はBさん、Cさんがお休みの為Aさんが「会議」、Dさんが「事務」。
金曜日はFさんが一人なのでそのままヘルプを表示。
マクロが空欄をエラーと認識してしまう為Fさんの業務を「ヘルプ」としました。

「最初に出現した業務を割り当てる。(優先1→優先4の順に検索)」
そうです!
各担当従業員の優先順位が高い業務から配置をするという事になります。
よろしくお願い致します。

お礼日時:2017/05/15 12:20

すみません。


確認4
⑥6人体制の場合
 3人体制と同様に決定し、残りの3人にサポートを割り当てる。

上記がもれてました。追加します。
    • good
    • 0

すみません。


確認4
④4人体制の場合
 3人体制と同様に決定し、残りの1人にサポートを割り当てる。

上記の④が2つありますが、1つは余分ですので、無視してください。
    • good
    • 0

確認1


>・一人、二人態勢の場合は「会議」、「営業」、「事務」の業務の中の「会議」と「事務」だけは優先順位が高い担当者で入力をしたいです。

では、以下の仕様でよろしいでしょうか。
1人体制の場合、会議、又は、事務の何れかを割り当てる。(どちらが割り当てられるかは事前には判らない)
2人体制の場合、会議、事務を割り当てる。

確認2
>※ただ従業員の研修期間で業務を担当出来ない方がいるのですが、設定表の担当業務に空欄がある箇所がある場合その担当者はそのまま空欄を出力させたいです。
>例としBさんの優先4の担当の「サポート」が空欄ならそのまま空欄など。

これは、要件として不適切です。
Bさんが、「会議」、「営業」、「事務」、空白と定義されても、
何日が研修日かの情報がないため、空白を何日の箇所に設定するのかが判りません。
研修期間で、当該業務を担当できない場合は、「研修」の文字を予め、いれておくことはできませんでしょうか。
例えば、Bさんが研修日が5月14,15,16日なら、15,16,17日へ「研修」の文字を設定しておきます。

マクロでは、空白の箇所のみを選んで、(つまり、「休」と「研修」)を除いて、その箇所へ業務を割り当てます。
運用上は、研修でも出張でもなんでもかまいません。そのセルが空白でなければ、割り当て不能とマクロは認識します。
従って該当日の空白の数が人数の体制になります。

確認3
担当者(Aさん~Fさん)の設定シートの業務の割り当ては、以下の仕様で行いますが宜しいでしょうか。
①優先1の場合、営業=1人、会議=1人、事務=1人、サポート=3人が割り当てられていること。
(以降、営業、会議、事務に割り当てられた要因を専従要員、サポートに割り当てられた要因をサポート要員と呼ぶ。
あなたの提示例では、Bさん,Cさん,Dさんが専従要員であり、以外の人がサポート要員となる。)
②各担当者は、優先1~優先4の割り当てで、営業、事務、会議、サポートが必ず1つずつ割り当てられていること。
例 Aさんに サポート、営業、事務、事務
  Bさんに 会議、営業、事務、空白
のような割り当てはエラーとなる。

確認4
割り当ては、要員を機会均等に割り当てるのではなく、最も優先順位の高い順に割り当てるようにしますが宜しいでしょうか。
①1人体制の場合、会議と事務の何れかを割り当て
 会議又は事務の専従要員なら、その業務を割り当てる。
 上記以外の要員なら、会議、事務が最初に出現した業務を割り当てる。(優先1→優先4の順に検索)
②2人体制の場合、会議と事務を割り当て
 2人とも会議又は事務の専従要員なら、その業務を割り当てる。
 1人が会議又は事務の専従要員なら、その業務を割り当てる。残りは、残りの業務を割り当てる。
 2人とも会議又は事務の専従要員でないなら、会議、事務が最初に出現した業務を割り当てる。(優先1→優先4の順に検索)
③3人体制の場合、会議、事務、営業を割り当て
 3人とも専従要員ならその業務を割り当てる。
 2人が専従要員ならその業務を割り当て、あとの1人は残りの業務を割り当てる。
 1人が専従要員ならその業務を割り当て、あとの2人は残りの業務が最初に出現した業務を割り当てる。(優先1→優先4の順に検索)
④4人体制の場合
 3人体制と同様に決定し、残りの1人にサポートを割り当てる。
④4人体制の場合
 3人体制と同様に決定し、残りの1人にサポートを割り当てる。
⑤5人体制の場合
 3人体制と同様に決定し、残りの2人にサポートを割り当てる。
    • good
    • 0

前回、


https://oshiete.goo.ne.jp/qa/9751595.html
で、回答したソースに1点、誤りがありました。
wk = dicT(key)
For i = 1 To 31
col = 2 + i ・・・・①
If sh2.Cells(2, col).Value = "" Then Exit For

①の箇所ですが、
C列から判定を開始するので、B列に休みが設定されることはありません。
col = 1 + i
が正しいです。お詫びして、訂正します。

ここからが本題ですが、
1)人数は5人限定になりますが宜しいでしょうか。
2)休みの設定は、別マクロで実施の前提なると、ありうる人数の体制は
1人・・・エラー
2人・・・エラー
3人
4人
5人
になります。
1人、2人の場合は、「会議」、「営業」、「事務」が確保できないので、エラーにしますが宜しいですか。
3)「会議」、「営業」、「事務」で重複の場合、赤表示とのことですが、
そもそも、これはあり得ないのではないでしょうか。
これが、発生する可能性があるのは、4人、5人の場合です。
(3人は会議、営業、事務を1人ずつ行う為、重複しない)
Aさん~Eさんは、優先順位はありますが、「会議」、「営業」、「事務」、「サポート」の何れかを選択することができます。
そうすると、「会議」、「営業」、「事務」の割り当て後、残りの人を強制的にサポートにすれば良いはずです。
あなたが、想定されている、重複ケースはどのような場合でしょうか。
(Aさん~Eさんの誰かが「サポート」の割り当てを持たないなら話は別ですが)
    • good
    • 0
この回答へのお礼

tatsu99様お世話になっております。訂正の件ありがとうございます。

本題の件についてご説明させていただきます。
・人数の限定は新人さんが一人増える予定なので「Fさん」を追加した6人限定でお願い致します。
・一人、二人態勢の場合は「会議」、「営業」、「事務」の業務の中の「会議」と「事務」だけは優先順位が高い担当者で入力をしたいです。
・重複の場合の赤表示はtatsu99様が仰る通り4、5人の場合になりますが、3業務を割り当て後、残りの担当者を強制的に「サポート」にする方法でお願い致します!
※ただ従業員の研修期間で業務を担当出来ない方がいるのですが、設定表の担当業務に空欄がある箇所がある場合その担当者はそのまま空欄を出力させたいです。
例としBさんの優先4の担当の「サポート」が空欄ならそのまま空欄など。

以上になります。
                    
よろしくお願い致します。

お礼日時:2017/05/14 14:11

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

QVBAシフト表における従業員の固定休のプログラムについて

VBAの従業員の固定休を求めるプログラムを教えていただきたいご質問になります。
添付した画像を例とします。
シートの名前を勤務管理表とし、A3セルから下にAさん、Bさん、Cさんと入力されています。
ここでは3名とします。
例えば別シートのA1セルにAさん。A2セルに休みの「金」、A3セルに「月」の文字を入力。
それを勤務管理表のAさんのB3セルから左のセル欄に「休」を出力し、またBさん、Cさんも同じ様に入力したい内容になります。

勤務管理表で従業員を50名程作成しなくてはならず作業効率向上の為、一括で入力したいと思いましたので、どなたか詳しい方のご回答をお待ちしております。
よろしくお願い致します。

Aベストアンサー

以下のマクロを標準モジュールへ登録してください。
休みの指定は、添付図のようにB~H迄の列に指定します。
1,2行はマクロ実行前に既に作成されていることが前提、A列の3行以降の従業員名も実行前に作成されていることが前提です。
-----------------------------------------------
Option Explicit
Public Sub 休日割当()
Dim sh1, sh2 As Worksheet
Dim dicT As Object
Dim row, col, maxrow As Long
Dim key, wk As String
Dim i As Long
Set dicT = CreateObject("Scripting.Dictionary")
Set sh1 = Worksheets("休日表")
Set sh2 = Worksheets("勤務管理表")
maxrow = sh1.Cells(Rows.Count, "A").End(xlUp).row 'Sheet1 A列最大行
'従業員の休みの曜日を取得
For row = 1 To maxrow
key = sh1.Cells(row, "A").Value
wk = ""
'B列からH列まで休みの曜日を取得
For col = 2 To 8
If sh1.Cells(row, col).Value = "" Then Exit For
wk = wk + sh1.Cells(row, col).Value
Next
dicT(key) = wk
Next
maxrow = sh2.Cells(Rows.Count, "A").End(xlUp).row 'Sheet2 A列最大行
'休みの設定領域をクリア
sh2.Range("B3:AF" & maxrow).Clear
For row = 3 To maxrow
key = sh2.Cells(row, "A").Value
If dicT.exists(key) = False Then
MsgBox (key & "は休日表に未登録です。処理を打ち切ります。")
Exit Sub
End If
wk = dicT(key)
For i = 1 To 31
col = 2 + i
If sh2.Cells(2, col).Value = "" Then Exit For
If InStr(wk, sh2.Cells(2, col).Value) > 0 Then
sh2.Cells(row, col).Value = "休"
sh2.Cells(row, col).Interior.ThemeColor = xlThemeColorDark1
sh2.Cells(row, col).Interior.TintAndShade = -0.249977111117893
End If
Next
Next
MsgBox ("完了")
End Sub

以下のマクロを標準モジュールへ登録してください。
休みの指定は、添付図のようにB~H迄の列に指定します。
1,2行はマクロ実行前に既に作成されていることが前提、A列の3行以降の従業員名も実行前に作成されていることが前提です。
-----------------------------------------------
Option Explicit
Public Sub 休日割当()
Dim sh1, sh2 As Worksheet
Dim dicT As Object
Dim row, col, maxrow As Long
Dim key, wk As String
Dim i As Long
Set dicT = CreateObject("Scripting.Dicti...続きを読む

Q日計シートから、担当者別の業務月報を作成したい

日計シートには、スタッフ全員の業務記録が有ります。
(担当者の名称は略称で入力されており、tableシートにフルネームと略称が有ります)
日計シートは作業の都度並べ替えがされており、日付、担当、時刻の順番に並んでいます。

上記のような日計データから、担当別の業務月報を作成したいです。
(担当別月報の冒頭にある担当者欄には、フルネームを記載したいです)

日計に書かれている担当者名と月報に記載する担当者名が異なること、
担当者の数が不定期に変わる(月ごとに)為、月報をどう作成したら良いか、
作成した月報は同保存すべきか・・・その辺に悩んでおります。
下記のような雰囲気を考えておりますが、何か良い方法が有ればご教示下さい。
(各シートのイメージ図を補足に付けます)

Dim i as long '繰り返し数
Dim stlest as long  'tableシートのスタッフ列の最下行番号
Dim sname as string '日計を抽出するスタッフ名称(略称)

stalest = Worksheets("table").Range("I15").End(xlUp).Row

for i = 2 to stlast

same = Worksheets("table").cells(i,10).value

(上記snameを使って日計シートを抽出?)
(この辺に担当者名の略称からフルネームを得るための何か?)

(各担当の名称から日計シートを抽出し、その値を月報シートへ?)
(印刷範囲セットとプレビュー)

next i

日計シートには、スタッフ全員の業務記録が有ります。
(担当者の名称は略称で入力されており、tableシートにフルネームと略称が有ります)
日計シートは作業の都度並べ替えがされており、日付、担当、時刻の順番に並んでいます。

上記のような日計データから、担当別の業務月報を作成したいです。
(担当別月報の冒頭にある担当者欄には、フルネームを記載したいです)

日計に書かれている担当者名と月報に記載する担当者名が異なること、
担当者の数が不定期に変わる(月ごとに)為、月報をどう作成し...続きを読む

Aベストアンサー

以下のマクロを標準モジュールへ登録してください。
-----------------------------------------------
Option Explicit
Public Sub 月報作成()
Dim bk1 As Workbook
Dim sh0, sh1, sh2 As Worksheet
Dim dicT As Object '氏名連想配列 キー:ニックネーム 値:フルネーム
Dim dicG As Object '月報連想配列 キー:月報のシート名 値:行番号
Dim yyyy, mm As Long '年、月
Dim maxrow0 As Long 'tableシート最大行数(I列)
Dim maxrow1 As Long '日計シート最大行数(A列)
Dim row, row2 As Long
Dim key As String
Dim sheetName As String
Dim newBook As String
Dim newBookpath As String
Dim ans As Long
Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set dicG = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set sh0 = Worksheets("table")
Set sh1 = Worksheets("日計")
Set sh2 = Worksheets("雛形")
yyyy = sh0.Cells(2, "A").Value
mm = sh0.Cells(3, "A").Value
maxrow0 = sh0.Cells(Rows.Count, "I").End(xlUp).row 'table I列 最終行を求める
maxrow1 = sh1.Cells(Rows.Count, "A").End(xlUp).row '日計 A列 最終行を求める
For row = 2 To maxrow0
key = sh0.Cells(row, "J").Value
If key <> "" Then
If dicT.exists(key) = True Then
MsgBox ("ニックネーム重複エラー:" & key)
Exit Sub
End If
'フルーネーム記憶
dicT(key) = sh0.Cells(row, "I").Value
End If
Next
'ニックネームの未登録チェック
For row = 2 To maxrow1
key = sh1.Cells(row, "J").Value
If dicT.exists(key) = False Then
MsgBox (key & "はtableに登録されていません")
Exit Sub
End If
Next
'新規ブックの存在チェック
newBookpath = ThisWorkbook.Path & "\" & yyyy & "年" & mm & "月分業務月報.xlsx"
If Dir(newBookpath) <> "" Then
ans = MsgBox(newBookpath & "が既に存在します。このファイルは上書きされます。続行しますか。", vbOKCancel)
If ans <> vbOK Then Exit Sub
Kill newBookpath
End If
'新規ブック作成
Workbooks.Add
'追加したブックの名前を取得
newBook = ActiveWorkbook.Name
'月報作成
Application.ScreenUpdating = False
For row = 2 To maxrow1
'ニックネーム取得
key = sh1.Cells(row, "J").Value
sheetName = dicT(key)
'最初のシートならシートを新規作成する
If dicG.exists(sheetName) = False Then
dicG(sheetName) = 5
sh2.Copy after:=Workbooks(newBook).Worksheets(Worksheets.Count)
Workbooks(newBook).Worksheets(Worksheets.Count).Name = sheetName
With Workbooks(newBook).Worksheets(sheetName)
.Cells(2, "A").Value = yyyy
.Cells(2, "C").Value = mm
.Cells(2, "G").Value = dicT(key)
End With
End If
row2 = dicG(sheetName)
With Workbooks(newBook).Worksheets(sheetName)
.Cells(row2, "A").Value = sh1.Cells(row, "A").Value '日付
.Cells(row2, "B").Value = sh1.Cells(row, "B").Value '時刻
.Cells(row2, "C").Value = sh1.Cells(row, "D").Value 'ID
.Cells(row2, "D").Value = sh1.Cells(row, "E").Value '顧客名
.Cells(row2, "E").Value = sh1.Cells(row, "F").Value 'メニュー
.Cells(row2, "F").Value = sh1.Cells(row, "H").Value '参考値A
.Cells(row2, "G").Value = sh1.Cells(row, "I").Value '参考値B
.Cells(row2, "H").Value = sh1.Cells(row, "K").Value '備考
End With
dicG(sheetName) = dicG(sheetName) + 1 '行番号加算
Next
'sheet1,2,3を削除
With Workbooks(newBook)
Application.DisplayAlerts = False 'シート削除時の警告を出さないようにする
.Worksheets("Sheet1").Delete
.Worksheets("Sheet2").Delete
.Worksheets("Sheet3").Delete
Application.DisplayAlerts = True 'シート削除時の警告を出すようにする(元に戻す)
End With
Application.ScreenUpdating = True
'新規ブックの保存
Set bk1 = Workbooks(newBook)
bk1.SaveAs Filename:=newBookpath
bk1.Close
MsgBox ("処理完了")
End Sub
----------------------------------------------
不明点は補足してください。

以下のマクロを標準モジュールへ登録してください。
-----------------------------------------------
Option Explicit
Public Sub 月報作成()
Dim bk1 As Workbook
Dim sh0, sh1, sh2 As Worksheet
Dim dicT As Object '氏名連想配列 キー:ニックネーム 値:フルネーム
Dim dicG As Object '月報連想配列 キー:月報のシート名 値:行番号
Dim yyyy, mm As Long '年、月
Dim maxrow0 As Long 'tableシート最大行数(I列)
Dim maxrow1 As Long '日計シート最大行数...続きを読む

QVBAの勤務割表の式を短く

 月間の勤務割表を作成しています。
1列3行を一枡として一人・一日の枡とし、勤務の割り振り状態を表示するものです。
列に日付、行を個人名(max16名)とし1列3行を名前の定義で13種類作成してあります。
別シートの各セルの入力番号に応じて13種類を貼り付けていますが、式を簡単にできませんでしようか?
 お教えくださいませんでしょうか?勉強不足は否めませんが。

尚名前の定義は、1行3列に1--で勤務1・""-""で日勤・""公休""で公等にしてあります。

OS Windows7 Office2010

Sub 図形の貼付け2()
If Worksheets("メイン").Range("J9").Value Then
Select Case Worksheets("メイン").Range("J9").Value 1人-1日
Case 1:
ActiveSheet.Range("勤務1").Select
Selection.Copy
Range("D10").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Case 2:
ActiveSheet.Range("勤務2").Select
Selection.Copy
Range("D10").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Case 3:
ActiveSheet.Range("勤務3").Select
Selection.Copy
Range("D10").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Case 4:
ActiveSheet.Range("日勤1").Select
Selection.Copy
Range("D10").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Case 5:
ActiveSheet.Range("日勤2").Select
Selection.Copy
Range("D10").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Case 6:
ActiveSheet.Range("日勤3").Select
Selection.Copy
Range("D10").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Select
Else
Select Case Worksheets("メイン").Range("I9").Value
Case 2:
ActiveSheet.Range("明け").Select
Selection.Copy
Range("D10").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Case 4:
ActiveSheet.Range("夜勤").Select
Selection.Copy
Range("D10").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Case 5:
ActiveSheet.Range("公").Select
Selection.Copy
Range("D10").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Case 6:
ActiveSheet.Range("有").Select
Selection.Copy
Range("D10").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Case 7:
ActiveSheet.Range("特").Select
Selection.Copy
Range("D10").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Case 8:
ActiveSheet.Range("振").Select
Selection.Copy
Range("D10").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Case 9:
ActiveSheet.Range("欠").Select
Selection.Copy
Range("D10").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Select
End If
End Sub

 月間の勤務割表を作成しています。
1列3行を一枡として一人・一日の枡とし、勤務の割り振り状態を表示するものです。
列に日付、行を個人名(max16名)とし1列3行を名前の定義で13種類作成してあります。
別シートの各セルの入力番号に応じて13種類を貼り付けていますが、式を簡単にできませんでしようか?
 お教えくださいませんでしょうか?勉強不足は否めませんが。

尚名前の定義は、1行3列に1--で勤務1・""-""で日勤・""公休""で公等にしてあります。

OS Windows7 Office2010

Sub 図形の貼付け2()
If ...続きを読む

Aベストアンサー

貼り付け処理を一元化するとか。

Q更に勤務割表の式を短く

 月間の勤務割表を作成しています。
1列3行を一枡として一人・一日の枡とし、勤務の割り振り状態を表示するものです。
列に日付、行を個人名(max16名)とし1列3行を名前の定義で15種類作成してあります。
同じシートの各セルの入力番号(2行3列を一升)でに応じて15種類を貼り付けていますが、1人-1日分は、式を短くできたのですが、16人-31日分までの式を簡単にできませんでしようか?この式を496回分作るのは、難儀ですので。

 お教えくださいませんでしょうか?勉強不足でこれが限界です。

尚名前の定義は、1行3列に1--で勤務1・""-""で日勤・""公休""で公等にしてあります。

OS Windows7 Office2010

Sub 名前の定義の貼付け() '1人-1日分
Dim addrname_workpattern As String
addrname_workpattern = ""
With Worksheets("メイン・2")
Select Case .Range("E70").Value
Case 1: addrname_workpattern = "勤務1"
Case 2: addrname_workpattern = "勤務2"
Case 3: addrname_workpattern = "勤務3"
Case 4: addrname_workpattern = "日勤1"
Case 5: addrname_workpattern = "日勤2"
Case 6: addrname_workpattern = "日勤3"
Case Else
Select Case .Range("D71").Value
Case 1: addrname_workpattern = "日勤4"
Case Else
Select Case .Range("D70").Value
Case 2: addrname_workpattern = "明け"
Case 3: addrname_workpattern = "日勤"
Case 4: addrname_workpattern = "夜勤"
Case 5: addrname_workpattern = "公"
Case 6: addrname_workpattern = "有"
Case 7: addrname_workpattern = "振"
Case 8: addrname_workpattern = "特"
Case 9: addrname_workpattern = "欠"
End Select
End Select
End Select
End With
If addrname_workpattern <> "" Then
ActiveSheet.Range(addrname_workpattern).Copy
Range("D8").PasteSpecial
Application.CutCopyMode = False
End If
End Sub

Sub 名前の定義の貼付け() '16人-31日分
Dim addrname_workpattern As String
addrname_workpattern = ""
With Worksheets("メイン・2")
Select Case .Range("CQ100").Value
Case 1: addrname_workpattern = "勤務1"
Case 2: addrname_workpattern = "勤務2"
Case 3: addrname_workpattern = "勤務3"
Case 4: addrname_workpattern = "日勤1"
Case 5: addrname_workpattern = "日勤2"
Case 6: addrname_workpattern = "日勤3"
Case Else
Select Case .Range("CP101").Value
Case 1: addrname_workpattern = "日勤4"
Case Else
Select Case .Range("CP100").Value
Case 2: addrname_workpattern = "明け"
Case 3: addrname_workpattern = "日勤"
Case 4: addrname_workpattern = "夜勤"
Case 5: addrname_workpattern = "公"
Case 6: addrname_workpattern = "有"
Case 7: addrname_workpattern = "振"
Case 8: addrname_workpattern = "特"
Case 9: addrname_workpattern = "欠"
End Select
End Select
End Select
End With
If addrname_workpattern <> "" Then
ActiveSheet.Range(addrname_workpattern).Copy
Range("CP23").PasteSpecial
Application.CutCopyMode = False
End If
End Sub

 月間の勤務割表を作成しています。
1列3行を一枡として一人・一日の枡とし、勤務の割り振り状態を表示するものです。
列に日付、行を個人名(max16名)とし1列3行を名前の定義で15種類作成してあります。
同じシートの各セルの入力番号(2行3列を一升)でに応じて15種類を貼り付けていますが、1人-1日分は、式を短くできたのですが、16人-31日分までの式を簡単にできませんでしようか?この式を496回分作るのは、難儀ですので。

 お教えくださいませんでしょうか?勉強不足でこれが限界です。

尚名前の定義は、...続きを読む

Aベストアンサー

>ちなみに Fox&Nextは、私も試行錯誤してやりましたが駄目でした。

どこがどうダメだったんでしょう?


全文を書くと、下記のようになります。

Sub 名前の定義の貼付け()
Dim addrname_workpattern As String
For i = 1 To 16
For j = 1 To 31
addrname_workpattern = ""
With Worksheets("メイン・2")
Select Case .Cells(70 + (i - 1) * 2, 5 + (j - 1) * 3).Value
Case 1: addrname_workpattern = "勤務1"
Case 2: addrname_workpattern = "勤務2"
Case 3: addrname_workpattern = "勤務3"
Case 4: addrname_workpattern = "日勤1"
Case 5: addrname_workpattern = "日勤2"
Case 6: addrname_workpattern = "日勤3"
Case Else
Select Case .Cells(71 + (i - 1) * 2, 4 + (j - 1) * 3).Value
Case 1: addrname_workpattern = "日勤4"
Case Else
Select Case .Cells(70 + (i - 1) * 2, 4 + (j - 1) * 3).Value
Case 2: addrname_workpattern = "明け"
Case 3: addrname_workpattern = "日勤"
Case 4: addrname_workpattern = "夜勤"
Case 5: addrname_workpattern = "公"
Case 6: addrname_workpattern = "有"
Case 7: addrname_workpattern = "振"
Case 8: addrname_workpattern = "特"
Case 9: addrname_workpattern = "欠"
End Select
End Select
End Select
End With
If addrname_workpattern <> "" Then
ActiveSheet.Range(addrname_workpattern).Copy
Cells(7 + i, 4 + (j - 1) * 3).PasteSpecial
Application.CutCopyMode = False
End If
Next
Next
End Sub

>ちなみに Fox&Nextは、私も試行錯誤してやりましたが駄目でした。

どこがどうダメだったんでしょう?


全文を書くと、下記のようになります。

Sub 名前の定義の貼付け()
Dim addrname_workpattern As String
For i = 1 To 16
For j = 1 To 31
addrname_workpattern = ""
With Worksheets("メイン・2")
Select Case .Cells(70 + (i - 1) * 2, 5 + (j - 1) * 3).Value
Case 1: addrname_workpattern = "勤務1"
Case 2: addrname_workpattern = "勤務2"
Case 3: addrname_workpattern = "勤務3"
Case 4: addrna...続きを読む

Q元データのシートにあるボタンを押すと、後ろのシートにデータをそのままコピーされてシートが追加できるようにしたい

大変困っています。

会員マスタという元データを作成し、そのシートに「シート追加」という
ボタンを作りました。

そのボタンを押すと、元データのシートの後ろにそのまま同じデータがコピーされて追加される様にVBAで設定したいです。

・行などはずれない様に設定したい。
・シート名は変更できるようにしたい。
・コピーして追加したシートにはボタンは表示されないようにしたい。

急いでます。知恵を貸してください。

Aベストアンサー

どんどん作るsheetに同じ名前は付けられませんので、連番にします。


'sheetの存在チェック
Private Function isExistSheet(sheetName As String) As Boolean
Dim ws As Worksheet
For Each ws In Worksheets
If ws.name = sheetName Then
isExistSheet = True
Exit Function
End If
Next
isExistSheet = False
End Function


'新しいシート名の検索
Function GetNewSheetName(newSheetName As String) As String
Dim n As Integer
n = 1
Do
If isExistSheet(newSheetName & str(n)) = False Then
Exit Do
End If
n = n + 1
Loop
GetNewSheetName = newSheetName & str(n)
End Function


Private Sub ボタン11_Click()
Dim ws As Worksheet
Dim newSheetName As String
newSheetName = "新しいシート" '追加シートの先頭名(適当な名前を付けてください)

Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '新しいシートを最後のシートの後ろに作る
Sheets("会員マスタ").Cells.Copy Destination:=ws.Cells(1, 1) '会員マスタのCellデータを新しいシートにコピー
ws.name = GetNewSheetName(newSheetName)'新しいシート名
End Sub

どんどん作るsheetに同じ名前は付けられませんので、連番にします。


'sheetの存在チェック
Private Function isExistSheet(sheetName As String) As Boolean
Dim ws As Worksheet
For Each ws In Worksheets
If ws.name = sheetName Then
isExistSheet = True
Exit Function
End If
Next
isExistSheet = False
End Function


'新しいシート名の検索
Function GetNewSheetName(newSheetName As String) As String
Dim n As Integer
n = 1
Do
If isEx...続きを読む


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング

おすすめ情報