はじめに
複数シートの連携では、2枚のシートを使って必要なデータを取る演習を行う。素材は昇給一覧表を用いる。
予約管理システムでは、必要な項目を入力して、ダブルブッキングしないような予約管理システムを作る。ただし、このプログラムはエラー処理をしていないので、空欄がないように入力して欲しい。詳しくは後ほど述べる操作方法を見て欲しい。
問題１
右側のシート（シート名は月額報酬）を検索して、左側のシート（シート名は昇給一覧）の月額報酬と差額を求めよ。ただし、差額はセルに直接関数を埋め込んでいる。
解答
VBAだからといって、コード一本やりではなくエクセルの関数と連携することも大切である。柔軟なやり方を考えて欲しい。
データ
▼昇給一覧シートにあるデータ
| 昇給前 | 昇給後 | 差分 | ||||||
| 番号 | 氏名 | 役職 | ランク | 月額報酬 | 役職 | ランク | 月額報酬 | 昇給額 |
| S015 | 小林 愛美 | スタッフ | Sランク | 244,000 | 主任補佐 | Bランク | - | |
| S016 | 柴田 悠斗 | 主任 | Sランク | 336,000 | 係長補佐 | Bランク | - | |
| S017 | 山崎 美月 | 係長 | Aランク | 422,000 | 係長 | Sランク | - | |
| S018 | 山口 愛莉 | 課長補佐 | Bランク | 463,000 | 課長補佐 | Aランク | - | |
| S019 | 工藤 太陽 | 部長 | Aランク | 739,000 | 部長 | Sランク | - | |
| S020 | 増田 萌花 | 課長 | Sランク | 587,000 | 部長補佐 | Bランク | - | |
| S021 | 宮崎 明日香 | 本部長補佐 | Aランク | 851,000 | 本部長補佐 | Sランク | - | |
| S022 | 藤田 美玖 | スタッフ | Bランク | 221,000 | 主任補佐 | Aランク | - |
▼月額報酬シートのデータ
| ランク 役職 |
Bランク | Aランク | Sランク |
| スタッフ | 221,000 | 232,000 | 244,000 |
| 主任補佐 | 265,000 | 278,000 | 292,000 |
| 主任 | 305,000 | 320,000 | 336,000 |
| 係長補佐 | 350,000 | 368,000 | 386,000 |
| 係長 | 402,000 | 422,000 | 443,000 |
| 課長補佐 | 463,000 | 486,000 | 510,000 |
| 課長 | 532,000 | 559,000 | 587,000 |
| 部長補佐 | 612,000 | 643,000 | 675,000 |
| 部長 | 704,000 | 739,000 | 776,000 |
| 本部長補佐 | 810,000 | 851,000 | 894,000 |
| 本部長 | 930,000 | 977,000 | 1,026,000 |
| 取締役 | 1,071,000 | 1,125,000 | 1,181,000 |
コード
Option Explicit
Option Base 1
Sub main()
Dim rw As Long, mnthpy As Long
Dim pstn As String, rnk As String
With Sheets("昇給一覧")
For rw = 3 To .UsedRange.Rows.Count
pstn = .Cells(rw, 6).Value
rnk = .Cells(rw, 7).Value
mnthpy = getMnthPy(pstn, rnk)
.Cells(rw, 8).Value = mnthpy
Next rw
End With
End Sub
ーーーーーーーーーーーーーーーーーーーーーーー
Function getMnthPy(pstn As String, rnk As String) As Long
Dim rw As Long, col As Long
With Sheets("月額報酬")
rw = WorksheetFunction.Match(pstn, .Columns(1), 0)
col = WorksheetFunction.Match(rnk, .Rows(1), 0)
getMnthPy = .Cells(rw, col).Value
End With
End Function
サブルーチンとファンクションプロシージャを使って、ランクと役職から該当するデータを取り出して、それを昇給一覧シートに貼り付けている。
mainの方では、昇給一覧の第6列と第7列を取り、それをファンクションプロシージャに渡し、ワークシート関数Matchに入れて、共通部分の値を取り出して、mainに引き渡している。
プログラムの流れは以上である。
コマンドボタンを昇給一覧シートに挿入してmainをマクロとして登録すればOKである。
問題２
入力欄にすべて入力して、予約のコマンドボタンを押したとき、予約カ所に氏名が表示され、すでに氏名が表示してある場合は、メッセージを出して重複入力を避けるようなプログラムを記述せよ。
解答
データ
| 日付 | 時間帯 | 会議室 | 予約者 | ||||||||
|
|
|||||||||||
| 日付 | 時間帯 | 大会議室 | 中会議室 | 小会議室A | 小会議室B | 小会議室C | |||||
| 10月3日 | 午前 | ||||||||||
| 午後1 | |||||||||||
| 午後2 | |||||||||||
| 10月4日 | 午前 | ||||||||||
| 午後1 | |||||||||||
| 午後2 | |||||||||||
| 10月5日 | 午前 | ||||||||||
| 午後1 | |||||||||||
| 午後2 | |||||||||||
| 10月6日 | 午前 | ||||||||||
| 午後1 | |||||||||||
| 午後2 | |||||||||||
| 10月7日 | 午前 | ||||||||||
| 午後1 | |||||||||||
| 午後2 | |||||||||||
コード
Option Explicit
Option Base 1
Sub main()
Dim mydate As Date
Dim mytime As String, discrm As String, resv As String, adrs As String
With Sheets("Sheet1")
mydate = Range("A2").Value
mytime = .Range("B2").Value
discrm = .Range("C2").Value
resv = .Range("D2").Value
adrs = getAddress(mydate, mytime, discrm)
If .Range(adrs).Value <> "" Then
MsgBox "既に予約済"
Else
.Range(adrs).Value = resv
.Range("A2:D2").ClearContents
End If
End With
End Sub
ーーーーーーーーーーーーーーーーーーーーーーー
Function getAddress(mydate As Date, mytime As String, discrm As String) As String
Dim i As Integer, myoffset As Integer, col As Integer
With Sheets("sheet1")
For i = 5 To .Cells(Rows.Count, 1).End(xlUp).Row Step 3
If .Cells(i, 1).Value = mydate Then
Exit For
End If
Next i
Select Case mytime
Case "午前"
myoffset = 0
Case "午後1"
myoffset = 1
Case "午後2"
myoffset = 2
End Select
col = WorksheetFunction.Match(discrm, .Rows(4), 0)
getAddress = .Cells(i + myoffset, col).Address
End With
End Function
ファンクションプロシージャで回すとき、step3で回していることに注意して欲しい。これは予約表の日時に対して、午前、午後１，午後２とフォーマットが決まっているためである。
入力欄の時間帯と会議室は、エクセルのプルダウンメニューを使って入力している。
クリックして表から時間帯と会議室を取る
他はコードを読めばいいかな、と思う。
操作手順
入力欄に全部を入力してコマンドボタンを押せば、その位置に氏名が入る。また重複した場合にはメッセージを出して終了する。間違えた場合は氏名をdelキーで消去するのだが、その後に正しいものを入力しないと、ゴミがでて、間違えた個所に名前が再度でてしまうので、注意して欲しい。
日付の入力は2023/10/3という形式を踏み、入力欄と表の日付部分をこの形式で表現すること。表のように10月3日とするには、セルの書式設定から行う。
ユーザーフォームを用いた入力例
コード
▼ユーザーフォーム
Option Explicit
Option Base 1
Private Sub UserForm_Initialize()
Dim i As Integer, j As Integer
For i = 2 To 4
ComboBox1.AddItem Sheets("Sheet1").Cells(i, 2)
Next i
For j = 3 To 7
ComboBox2.AddItem Sheets("Sheet1").Cells(1, j)
Next j
End Sub
ーーーーーーーーーーーーーーーーーーーーーーー
Private Sub TextBox1_Change()
dttime = TextBox1.Value
End Sub
ーーーーーーーーーーーーーーーーーーーーーーー
Private Sub ComboBox1_Change()
mytime = ComboBox1.Value
End Sub
ーーーーーーーーーーーーーーーーーーーーーーー
Private Sub ComboBox2_Change()
discrm = ComboBox2.Value
End Sub
ーーーーーーーーーーーーーーーーーーーーーーー
Private Sub TextBox2_Change()
resv = TextBox2.Value
End Sub
ーーーーーーーーーーーーーーーーーーーーーーー
▼メインプロシージャ
Option Explicit
Option Base 1
Public dttime As String, mytime As String, discrm As String, resv As String, adrs As String
Sub main()
Dim mydate As Date
UserForm1.Show
With Sheets("Sheet1")
mydate = CDate(dttime)
adrs = getAddress(mydate, mytime, discrm)
If .Range(adrs).Value <> "" Then
MsgBox "既に予約済か" & vbCrLf & _
"ユーザーフォームが未入力です" & vbCrLf & _
"再入力してください"
Else
.Range(adrs).Value = resv
End If
End With
End Sub
Function getAddress(mydate As Date, mytime As String, discrm As String) As String
Dim i As Integer, myoffset As Integer, col As Integer
With Sheets("sheet1")
For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row Step 3
If .Cells(i, 1).Value = mydate Then
Exit For
End If
Next i
Select Case mytime
Case "午前"
myoffset = 0
Case "午後1"
myoffset = 1
Case "午後2"
myoffset = 2
End Select
col = WorksheetFunction.Match(discrm, .Rows(1), 0)
getAddress = .Cells(i + myoffset, col).Address
End With
End Function
サイトご利用方法
次のページ・前のページを利用するよりも、グローバルメニュー（ヘッダー部分にある項目）・サブメニュー記事の項目をクリックしていただければ、その項目の全体像が一目でみることができ、クリックすればそのサイトへ飛びます。
google、yahoo、Bingなどで検索する場合、検索ワードは先頭に、孤立じじい、と入力しその後に、グローバルメニュー・サブメニュー記事のどれかひとつの項目を入力すると、その検索サイトが上位表示されます。