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
0 コメント