【VBA】ReDim文の中で条件分岐させる方法

前提

VBAで今日現在および任意の日の社員名簿を出力するマクロを作っています。以下の4シートを使用します。

異動DB
組織マスター
社員基本情報
現在の社員名簿

該当のソースコード

「異動DB」「組織マスター」「社員基本情報」を参照して、「現在の社員名簿」に書き込むコードです。

VBA
1Sub meibokosin(d As Date, c As Collection)
2    '複数枚のシートを合わせて社員名簿を作る
3    
4    Dim kubun As Integer, today_d As Date, str_d As Date, end_d As Date
5    Dim no As Integer, syain_no As Long
6    Dim honbu As String, bu As String, ka As String, kakari As String
7    Dim sosikicode As Long, kakuzuke As String, kakuzuke_code As Long
8    Dim yakusyoku As String, yakusyoku_code As Integer, simei As String, seibetu As String, seinengappi As Long, nyusyabi As Long, _
9    mailadd As String, gakureki As String, kenpo_no As String, nenkin_no As String, kisonenkin_no As String
10    Dim honbucode As Long, syozoku As String, syozoku_code As Long
11    
12    Const AddCol As Long = 128          '追加列数
13    Dim aval(AddCol - 1) As Variant     '追加列分格納領域
14    Dim i As Long                       '添え字
15        
16    Dim wS1 As Worksheet
17    Dim wS2 As Worksheet
18    Dim wS3 As Worksheet
19    Dim wS4 As Worksheet
20    
21    'ワークシートを変数で宣言する
22    Set wS1 = Worksheets("異動DB")
23    Set wS2 = Worksheets("組織マスター")
24    Set wS3 = Worksheets("社員基本情報")
25    Set wS4 = Worksheets("現在の社員名簿")
26
27    'ワークシートに出力している間の画面更新を停止
28    Application.ScreenUpdating = False
29    wS4.Activate
30
31    '前の結果をクリアする
32    n = wS4.Cells(Rows.Count, 1).End(xlUp).Row
33    If n > 2 Then
34        wS4.Range(Cells(3, 1), Cells(n, 151)).ClearContents
35        wS4.Range(Cells(3, 1), Cells(n, 151)).Borders.LineStyle = xlLineStyleNone
36    End If
37
38    '各シートの値を変数にセットする
39    For m = 1 To c.Count
40        R = c(m)
41        
42        '「異動DB」
43        With wS1
44            today_d = d
45            kubun = .Cells(R, 1)
46            str_d = .Cells(R, 2)
47            end_d = .Cells(R, 3)
48            no = R
49            syain_no = .Cells(R, 4)
50            simei = .Cells(R, 5)
51            honbu = .Cells(R, 6)
52            bu = .Cells(R, 7)
53            ka = .Cells(R, 8)
54            kakari = .Cells(R, 9)
55            kakuzuke = .Cells(R, 10)
56            yakusyoku = .Cells(R, 11)
57            syozoku = .Cells(R, 12)
58        End With
59        
60        '「社員基本情報」
61        Set rcd = wS3.Range("a:a").Find(syain_no, lookat:=xlWhole)
62        If Not rcd Is Nothing Then
63            seibetu = rcd.Offset(0, 2)
64            seinengappi = rcd.Offset(0, 3)
65            nyusyabi = rcd.Offset(0, 4)
66            mailadd = rcd.Offset(0, 5)
67            gakureki = rcd.Offset(0, 6)
68            kenpo_no = rcd.Offset(0, 7)
69            nenkin_no = rcd.Offset(0, 8)
70            kisonenkin_no = rcd.Offset(0, 9)
71            
72            For i = 0 To UBound(aval)
73                aval(i) = rcd.Offset(0, 10 + i)
74            Next
75        End If
76               
77        '「組織マスター」
78        With wS2
79            Set rcd_honbu = .Range("a:a").Find(honbu, lookat:=xlWhole)
80            Set rcd_bu = .Range("c:c").Find(bu, lookat:=xlWhole)
81            Set rcd_ka = .Range("e:e").Find(ka, lookat:=xlWhole)
82            Set rcd_kakari = .Range("g:g").Find(kakari, lookat:=xlWhole)
83            
84            Set rcd_kakuzuke = .Range("k:k").Find(kakuzuke, lookat:=xlWhole)
85            kakuzuke_code = rcd_kakuzuke.Offset(0, 1)
86            
87            Set rcd_yakusyoku = .Range("m:m").Find(yakusyoku, lookat:=xlWhole)
88            yakusyoku_code = rcd_yakusyoku.Offset(0, 1)
89            
90            Set rcd_syozoku = .Range("i:i").Find(syozoku, lookat:=xlWhole)
91            syozoku_code = rcd_syozoku.Offset(0, 1)
92        End With
93        
94        '退職（区分:3）を除く任意の日の各社員データを書き込む
95        Dim arr() As Variant
96        If (kubun <> 3 And str_d <= today_d And today_d <= end_d) Or _
97           (str_d <= today_d And end_d = 0) Or _
98           (kubun <> 3 And str_d > today_d And end_d = 0) Then
99            ReDim Preserve arr(151, p)
100                arr(0, p) = no
101                arr(1, p) = syain_no
102                arr(2, p) = honbu
103                arr(3, p) = bu
104                arr(4, p) = ka
105                arr(5, p) = kakari
106                arr(6, p) = sosikicode
107                arr(7, p) = kakuzuke
108                arr(8, p) = kakuzuke_code
109                arr(9, p) = yakusyoku
110                arr(10, p) = yakusyoku_code
111                arr(11, p) = simei
112                arr(12, p) = seibetu
113                arr(13, p) = seinengappi
114                arr(14, p) = nyusyabi
115                arr(15, p) = mailadd
116                arr(16, p) = gakureki
117                arr(17, p) = kenpo_no
118                arr(18, p) = nenkin_no
119                arr(19, p) = kisonenkin_no
120                arr(20, p) = honbucode
121                arr(21, p) = syozoku
122                arr(22, p) = syozoku_code                
123                For i = 0 To UBound(aval)
124                    arr(23 + i, p) = aval(i)
125                Next
126
127            p = p + 1
128        End If
129    Next m
130    
131    With wS4.Range("a3").Resize(p, 151)
132         .Value = Application.WorksheetFunction.Transpose(arr)
133    End With
134    
135    Application.ScreenUpdating = True    
136End Sub

実現したいこと

今後入社予定の社員データを出力するため「今日あるいは未来の日の社員名簿」を出力するコードを書きましたが、「今日現在の社員名簿」も同時に別シートで出力するコードを書き加えたいです。

試したこと

新たに出力するシートは以下の通りで、97行目以降のIf文のうち3番目の条件（「区分が3でない」かつ「開始日が今日より後」かつ「終了日」）を無くして、「今日現在の各社員データ」を書くようにします。

    Dim wS5 As Worksheet  
    Set wS5 = Worksheets("今日時点の社員名簿")

        '今日現在の各社員データを書き込む
        Dim arr() As Variant
        If (kubun <> 3 And str_d <= today_d And today_d <= end_d) Or _
           (str_d <= today_d And end_d = 0) Then
            ReDim Preserve arr(151, p)
                arr(0, p) = no
                arr(1, p) = syain_no
                arr(2, p) = honbu
                arr(3, p) = bu
                arr(4, p) = ka
                arr(5, p) = kakari
                arr(6, p) = sosikicode
                arr(7, p) = kakuzuke
                arr(8, p) = kakuzuke_code
                arr(9, p) = yakusyoku
                arr(10, p) = yakusyoku_code
                arr(11, p) = simei
                arr(12, p) = seibetu
                arr(13, p) = seinengappi
                arr(14, p) = nyusyabi
                arr(15, p) = mailadd
                arr(16, p) = gakureki
                arr(17, p) = kenpo_no
                arr(18, p) = nenkin_no
                arr(19, p) = kisonenkin_no
                arr(20, p) = honbucode
                arr(21, p) = syozoku
                arr(22, p) = syozoku_code
                
                For i = 0 To UBound(aval)
                    arr(23 + i, p) = aval(i)
                Next

            p = p + 1
        End If
    Next m
    
    With wS5.Range("a3").Resize(p, 151)
         .Value = Application.WorksheetFunction.Transpose(arr)
    End With

もちろん別のSubで同じように書くことで別シートに書き込むことはできますが、出来れば1つのプロシージャ内で条件分岐で出力できるようにしたいので、アドバイスいただければと思います。よろしくお願いいたします。

補足情報（FW/ツールのバージョンなど）

PC：Windows11
ソフト：Microsoft365 Excel
参考URL:社員名簿を作る～その2～

行動規範の内容に同意します

回答2件

ベストアンサー

meibokosinの1回の呼び出して、現在の社員名簿と今日時点の社員名簿を出力せずに、
meibokosinの1回の呼び出して、指定したどちらかのシートを出力するようにします。
meibokosinの呼び出し側は
call meibokosin(△,〇)のようにしているかと思いますが、以下のように変えます。
call meibokosin(△,〇,1)・・・・・現在の社員名簿の出力
call meibokosin(△,〇,2)・・・・・今日時点の社員名簿の出力
meibokosinを以下のように変えます。

VBA
1'out_type 1:現在の社員名簿 2:今日時点の社員名簿
2Sub meibokosin(d As Date, c As Collection, ByVal out_type As Long)
3'複数枚のシートを合わせて社員名簿を作る
4
5    Dim kubun As Integer, today_d As Date, str_d As Date, end_d As Date
6    Dim no As Integer, syain_no As Long
7    Dim honbu As String, bu As String, ka As String, kakari As String
8    Dim sosikicode As Long, kakuzuke As String, kakuzuke_code As Long
9    Dim yakusyoku As String, yakusyoku_code As Integer, simei As String, seibetu As String, seinengappi As Long, nyusyabi As Long, _
10        mailadd As String, gakureki As String, kenpo_no As String, nenkin_no As String, kisonenkin_no As String
11    Dim honbucode As Long, syozoku As String, syozoku_code As Long
12
13    Const AddCol As Long = 128          '追加列数
14    Dim aval(AddCol - 1) As Variant     '追加列分格納領域
15    Dim i As Long                       '添え字
16
17    Dim wS1 As Worksheet
18    Dim wS2 As Worksheet
19    Dim wS3 As Worksheet
20    Dim wS4 As Worksheet
21
22    'ワークシートを変数で宣言する
23    Set wS1 = Worksheets("異動DB")
24    Set wS2 = Worksheets("組織マスター")
25    Set wS3 = Worksheets("社員基本情報")
26    If out_type = 1 Then
27        Set wS4 = Worksheets("現在の社員名簿")
28    End If
29    If out_type = 2 Then
30        Set wS4 = Worksheets("今日時点の社員名簿")
31    End If
32
33    'ワークシートに出力している間の画面更新を停止
34    Application.ScreenUpdating = False
35    wS4.Activate
36
37    '前の結果をクリアする
38    n = wS4.Cells(Rows.Count, 1).End(xlUp).Row
39    If n > 2 Then
40        wS4.Range(Cells(3, 1), Cells(n, 151)).ClearContents
41        wS4.Range(Cells(3, 1), Cells(n, 151)).Borders.LineStyle = xlLineStyleNone
42    End If
43
44    '各シートの値を変数にセットする
45    For m = 1 To c.Count
46        r = c(m)
47
48        '「異動DB」
49        With wS1
50            today_d = d
51            kubun = .Cells(r, 1)
52            str_d = .Cells(r, 2)
53            end_d = .Cells(r, 3)
54            no = r
55            syain_no = .Cells(r, 4)
56            simei = .Cells(r, 5)
57            honbu = .Cells(r, 6)
58            bu = .Cells(r, 7)
59            ka = .Cells(r, 8)
60            kakari = .Cells(r, 9)
61            kakuzuke = .Cells(r, 10)
62            yakusyoku = .Cells(r, 11)
63            syozoku = .Cells(r, 12)
64        End With
65
66        '「社員基本情報」
67        Set rcd = wS3.Range("a:a").Find(syain_no, lookat:=xlWhole)
68        If Not rcd Is Nothing Then
69            seibetu = rcd.Offset(0, 2)
70            seinengappi = rcd.Offset(0, 3)
71            nyusyabi = rcd.Offset(0, 4)
72            mailadd = rcd.Offset(0, 5)
73            gakureki = rcd.Offset(0, 6)
74            kenpo_no = rcd.Offset(0, 7)
75            nenkin_no = rcd.Offset(0, 8)
76            kisonenkin_no = rcd.Offset(0, 9)
77
78            For i = 0 To UBound(aval)
79                aval(i) = rcd.Offset(0, 10 + i)
80            Next
81        End If
82
83        '「組織マスター」
84        With wS2
85            Set rcd_honbu = .Range("a:a").Find(honbu, lookat:=xlWhole)
86            Set rcd_bu = .Range("c:c").Find(bu, lookat:=xlWhole)
87            Set rcd_ka = .Range("e:e").Find(ka, lookat:=xlWhole)
88            Set rcd_kakari = .Range("g:g").Find(kakari, lookat:=xlWhole)
89
90            Set rcd_kakuzuke = .Range("k:k").Find(kakuzuke, lookat:=xlWhole)
91            kakuzuke_code = rcd_kakuzuke.Offset(0, 1)
92
93            Set rcd_yakusyoku = .Range("m:m").Find(yakusyoku, lookat:=xlWhole)
94            yakusyoku_code = rcd_yakusyoku.Offset(0, 1)
95
96            Set rcd_syozoku = .Range("i:i").Find(syozoku, lookat:=xlWhole)
97            syozoku_code = rcd_syozoku.Offset(0, 1)
98        End With
99
100        Dim arr() As Variant
101        Dim flag As Boolean
102        flag = False
103        If out_type = 1 Then
104            '退職（区分:3）を除く任意の日の各社員データを書き込む
105            If (kubun <> 3 And str_d <= today_d And today_d <= end_d) Or _
106               (str_d <= today_d And end_d = 0) Or _
107               (kubun <> 3 And str_d > today_d And end_d = 0) Then
108                flag = True
109            End If
110        End If
111        If out_type = 2 Then
112            '今日現在の各社員データを書き込む
113            If (kubun <> 3 And str_d <= today_d And today_d <= end_d) Or _
114               (str_d <= today_d And end_d = 0) Then
115                flag = True
116            End If
117        End If
118        If flag = True Then
119            ReDim Preserve arr(151, p)
120            arr(0, p) = no
121            arr(1, p) = syain_no
122            arr(2, p) = honbu
123            arr(3, p) = bu
124            arr(4, p) = ka
125            arr(5, p) = kakari
126            arr(6, p) = sosikicode
127            arr(7, p) = kakuzuke
128            arr(8, p) = kakuzuke_code
129            arr(9, p) = yakusyoku
130            arr(10, p) = yakusyoku_code
131            arr(11, p) = simei
132            arr(12, p) = seibetu
133            arr(13, p) = seinengappi
134            arr(14, p) = nyusyabi
135            arr(15, p) = mailadd
136            arr(16, p) = gakureki
137            arr(17, p) = kenpo_no
138            arr(18, p) = nenkin_no
139            arr(19, p) = kisonenkin_no
140            arr(20, p) = honbucode
141            arr(21, p) = syozoku
142            arr(22, p) = syozoku_code
143            For i = 0 To UBound(aval)
144                arr(23 + i, p) = aval(i)
145            Next
146
147            p = p + 1
148        End If
149    Next m
150
151    With wS4.Range("a3").Resize(p, 151)
152        .Value = Application.WorksheetFunction.Transpose(arr)
153    End With
154
155    Application.ScreenUpdating = True
156End Sub

こちらで、動作環境が作れなかったので、動作確認はしていません。不明点があれば、補足してください。
変えた個所は、
If out_type = 1 Then
・・・
end if
If out_type = 2 Then
・・・
end if
です。
今後、第３のシートを出力する要件が発生した場合は、
If out_type = 3 Then
・・・
end if
のようにすれば、追加可能です。

投稿2023/02/15 06:22

tatsu99

総合スコア5438

koburon

2023/02/15 08:44

回答ありがとうございます。 meibokosinの中で処理させるコードで行ってみたのですが、ブックを開いて自動で動作させるようにしたところ、 35行目 wS4.Activate ここで「実行時エラー'91'」で中断してしまいました。 ws4が定義されていないという意味なのでしょうか？

tatsu99

2023/02/15 08:56

そのときのout_typeの値はどうなっていますか。 out_typeが1又は2であれば、wS4は値が設定されているのでエラーにならないはずです。 out_typeが上記以外なら、wS4は未設定なのでエラーになります。

tatsu99

2023/02/15 08:58

meibokosinを呼び出している個所はどうなっていますか？ call meibokosin(△,〇,1)・・・・・現在の社員名簿の出力のようになっていますか？

koburon

2023/02/16 02:37

meibokoshinを呼び出すコードですが、Call meibokosin(d, c, out_type) としていました。下記のように分けて書き、更新の動作を確認しました。 Sub syokika() 'ブックを開くと自動で組織リスト・社員名簿を今日の日付で更新する Application.ScreenUpdating = False Dim d As Date d = Date Dim c As Collection Set c = New Collection For i = 2 To Worksheets("異動DB").Cells(Rows.Count, 1).End(xlUp).Row c.add i Next i '処理1(現在の社員名簿の更新) Call meibokosin(d, c, 1) '処理2(今日時点の社員名簿の更新) Call meibokosin(d, c, 2) Application.ScreenUpdating = True End Sub ただ、今度は40行目で「実行時エラー'1004'」('Range'メソッドは失敗しました。'_Worksheet'オブジェクト)で中断してしまいました。「wS4」の参照先が間違っているか指定されていないかだと思いますが、書き加える必要があるのでしょうか。

tatsu99

2023/02/16 02:54

39-42の下記の行ですが If n > 2 Then wS4.Range(Cells(3, 1), Cells(n, 151)).ClearContents wS4.Range(Cells(3, 1), Cells(n, 151)).Borders.LineStyle = xlLineStyleNone End If これを If n > 2 Then wS4.Range(wS4.Cells(3, 1), wS4.Cells(n, 151)).ClearContents wS4.Range(wS4.Cells(3, 1), wS4.Cells(n, 151)).Borders.LineStyle = xlLineStyleNone End If のように書き換えてください。 wS4.Range(Cells(3, 1), Cells(n, 151))の Cells(3, 1)は、ActiveSheetのCells(3, 1)になるのでwS4と異なる可能性があります。今後は、必ず、シート名をつけて修飾するようにしてください。

koburon

2023/02/16 03:01

よく確認したところ、meibokosinの35行目：wS4.Activateの先頭部に「'」をつけてエスケープさせていました。外して実行したところ、正しく2枚のシートに社員名簿が出力されました。せっかく追記していただいたのに確認不足で申し訳ありません。一応、時間があるのでいただいたコードを加えるとどうなるか確認してみます。

tatsu99

2023/02/16 03:27

>外して実行したところ、正しく2枚のシートに社員名簿が出力されました。 >一応、時間があるのでいただいたコードを加えるとどうなるか確認してみます。了解しました。

koburon

2023/02/16 04:08

コードを追記して動作確認しましたが、問題なく書き込まれました。今回はエラー回避できましたが、今後は参照シートを指定する癖を付けておく必要がありますね。

tatsu99

2023/02/16 04:22

>今回はエラー回避できましたが、今後は参照シートを指定する癖を付けておく必要がありますね。この箇所はみんなが陥りやすい罠ですね。原因が特定しずらく私もはまりました。一回、痛い目にあうと、次からは大丈夫だと思います。

koburon

2023/02/16 06:15

>一回、痛い目にあうと、次からは大丈夫だと思います。了解しました。最後まで細かい要望までコメントしてご対応いただきありがとうございました。

行動規範の内容に同意します

前回の回答は、出力シート毎の処理をmeibokosinの中で行ってますが、これを外だしにしてすっきりさせたのが、以下の方法です。
set_wS4とOutConditionを作成し、それをmeibokosinから呼び出します。
set_wS4とOutConditionで参照する変数が多いので、以下の変数を共有変数にしています。
Dim kubun As Integer, today_d As Date, str_d As Date, end_d As Date
Dim wS4 As Worksheet

VBA
1'共有変数
2Dim kubun As Integer, today_d As Date, str_d As Date, end_d As Date
3Dim wS4 As Worksheet
4
5'out_type 1:現在の社員名簿 2:今日時点の社員名簿
6Sub meibokosin(d As Date, c As Collection, ByVal out_type As Long)
7'複数枚のシートを合わせて社員名簿を作る
8
9    Dim no As Integer, syain_no As Long
10    Dim honbu As String, bu As String, ka As String, kakari As String
11    Dim sosikicode As Long, kakuzuke As String, kakuzuke_code As Long
12    Dim yakusyoku As String, yakusyoku_code As Integer, simei As String, seibetu As String, seinengappi As Long, nyusyabi As Long, _
13        mailadd As String, gakureki As String, kenpo_no As String, nenkin_no As String, kisonenkin_no As String
14    Dim honbucode As Long, syozoku As String, syozoku_code As Long
15
16    Const AddCol As Long = 128          '追加列数
17    Dim aval(AddCol - 1) As Variant     '追加列分格納領域
18    Dim i As Long                       '添え字
19
20    Dim wS1 As Worksheet
21    Dim wS2 As Worksheet
22    Dim wS3 As Worksheet
23
24    'ワークシートを変数で宣言する
25    Set wS1 = Worksheets("異動DB")
26    Set wS2 = Worksheets("組織マスター")
27    Set wS3 = Worksheets("社員基本情報")
28    '出力シートを設定する
29    Call set_wS4(out_type)
30
31    'ワークシートに出力している間の画面更新を停止
32    Application.ScreenUpdating = False
33    wS4.Activate
34
35    '前の結果をクリアする
36    n = wS4.Cells(Rows.Count, 1).End(xlUp).Row
37    If n > 2 Then
38        wS4.Range(Cells(3, 1), Cells(n, 151)).ClearContents
39        wS4.Range(Cells(3, 1), Cells(n, 151)).Borders.LineStyle = xlLineStyleNone
40    End If
41
42    '各シートの値を変数にセットする
43    For m = 1 To c.Count
44        r = c(m)
45
46        '「異動DB」
47        With wS1
48            today_d = d
49            kubun = .Cells(r, 1)
50            str_d = .Cells(r, 2)
51            end_d = .Cells(r, 3)
52            no = r
53            syain_no = .Cells(r, 4)
54            simei = .Cells(r, 5)
55            honbu = .Cells(r, 6)
56            bu = .Cells(r, 7)
57            ka = .Cells(r, 8)
58            kakari = .Cells(r, 9)
59            kakuzuke = .Cells(r, 10)
60            yakusyoku = .Cells(r, 11)
61            syozoku = .Cells(r, 12)
62        End With
63
64        '「社員基本情報」
65        Set rcd = wS3.Range("a:a").Find(syain_no, lookat:=xlWhole)
66        If Not rcd Is Nothing Then
67            seibetu = rcd.Offset(0, 2)
68            seinengappi = rcd.Offset(0, 3)
69            nyusyabi = rcd.Offset(0, 4)
70            mailadd = rcd.Offset(0, 5)
71            gakureki = rcd.Offset(0, 6)
72            kenpo_no = rcd.Offset(0, 7)
73            nenkin_no = rcd.Offset(0, 8)
74            kisonenkin_no = rcd.Offset(0, 9)
75
76            For i = 0 To UBound(aval)
77                aval(i) = rcd.Offset(0, 10 + i)
78            Next
79        End If
80
81        '「組織マスター」
82        With wS2
83            Set rcd_honbu = .Range("a:a").Find(honbu, lookat:=xlWhole)
84            Set rcd_bu = .Range("c:c").Find(bu, lookat:=xlWhole)
85            Set rcd_ka = .Range("e:e").Find(ka, lookat:=xlWhole)
86            Set rcd_kakari = .Range("g:g").Find(kakari, lookat:=xlWhole)
87
88            Set rcd_kakuzuke = .Range("k:k").Find(kakuzuke, lookat:=xlWhole)
89            kakuzuke_code = rcd_kakuzuke.Offset(0, 1)
90
91            Set rcd_yakusyoku = .Range("m:m").Find(yakusyoku, lookat:=xlWhole)
92            yakusyoku_code = rcd_yakusyoku.Offset(0, 1)
93
94            Set rcd_syozoku = .Range("i:i").Find(syozoku, lookat:=xlWhole)
95            syozoku_code = rcd_syozoku.Offset(0, 1)
96        End With
97
98        Dim arr() As Variant
99        '出力シート対応に出力条件を判定する
100        If OutCondition(out_type) = True Then
101            ReDim Preserve arr(151, p)
102            arr(0, p) = no
103            arr(1, p) = syain_no
104            arr(2, p) = honbu
105            arr(3, p) = bu
106            arr(4, p) = ka
107            arr(5, p) = kakari
108            arr(6, p) = sosikicode
109            arr(7, p) = kakuzuke
110            arr(8, p) = kakuzuke_code
111            arr(9, p) = yakusyoku
112            arr(10, p) = yakusyoku_code
113            arr(11, p) = simei
114            arr(12, p) = seibetu
115            arr(13, p) = seinengappi
116            arr(14, p) = nyusyabi
117            arr(15, p) = mailadd
118            arr(16, p) = gakureki
119            arr(17, p) = kenpo_no
120            arr(18, p) = nenkin_no
121            arr(19, p) = kisonenkin_no
122            arr(20, p) = honbucode
123            arr(21, p) = syozoku
124            arr(22, p) = syozoku_code
125            For i = 0 To UBound(aval)
126                arr(23 + i, p) = aval(i)
127            Next
128
129            p = p + 1
130        End If
131    Next m
132
133    With wS4.Range("a3").Resize(p, 151)
134        .Value = Application.WorksheetFunction.Transpose(arr)
135    End With
136
137    Application.ScreenUpdating = True
138End Sub
139
140
141Private Sub set_wS4(ByVal out_type As Long)
142    If out_type = 1 Then
143        Set wS4 = Worksheets("現在の社員名簿")
144    End If
145    If out_type = 2 Then
146        Set wS4 = Worksheets("今日時点の社員名簿")
147    End If
148End Sub
149
150Private Function OutCondition(ByVal out_type As Long)
151    OutCondition = False
152    If out_type = 1 Then
153        '退職（区分:3）を除く任意の日の各社員データを書き込む
154        If (kubun <> 3 And str_d <= today_d And today_d <= end_d) Or _
155           (str_d <= today_d And end_d = 0) Or _
156           (kubun <> 3 And str_d > today_d And end_d = 0) Then
157            OutCondition = True
158        End If
159    End If
160    If out_type = 2 Then
161        '今日現在の各社員データを書き込む
162        If (kubun <> 3 And str_d <= today_d And today_d <= end_d) Or _
163           (str_d <= today_d And end_d = 0) Then
164            OutCondition = True
165        End If
166    End If
167End Function
168