VBA
1Sub meibokosin(d As Date, c As Collection) 2 3 Dim kubun As Integer, today_d As Date, str_d As Date, end_d As Date 4 Dim no As Integer, syain_no As Integer, honbu As String, bu As String, ka As String, kakari As String, sosikicode As Long, _ 5 koyo_keitai As String, koyo_keitai_code As Integer, syokusyou As String, kakuzuke1 As String, kakuzuke2 As String, kakuzuke_code As Long, _ 6 yakusyoku As String, yakusyoku_code As Integer, simei As String, seibetu As String, seinengappi As Date, nenrei As Integer, ketuekigata As String, nyusyabi As Date, _ 7 kinzokunensuu As Integer, yuubinbangou As String, jyuusyo As String, denwabangou As String, keitaibangou As String, _ 8 mailadd As String, gakureki As String, kenpo_no As Integer, nenkin_no As Integer, kisonenkin_no As String 9 10 Dim wS1 As Worksheet 11 Dim wS2 As Worksheet 12 Dim wS3 As Worksheet 13 Dim wS4 As Worksheet 14 15 'ワークシートを変数で宣言する 16 Set wS1 = Worksheets("異動DB") 17 Set wS2 = Worksheets("組織マスター") 18 Set wS3 = Worksheets("社員基本情報") 19 Set wS4 = Worksheets("現在の社員名簿") 20 21 wS4.Activate 22 23 n = wS4.Cells(Rows.Count, 1).End(xlUp).Row 24 If n > 2 Then 25 wS4.Range(Cells(3, 1), Cells(n, 31)).ClearContents 26 wS4.Range(Cells(3, 1), Cells(n, 31)).Borders.LineStyle = xlLineStyleNone 27 End If 28 29 30 For m = 1 To c.Count 31 R = c(m) 32 With wS1 33 today_d = d 34 kubun = .Cells(R, 1) 35 str_d = .Cells(R, 2) 36 end_d = .Cells(R, 3) 37 no = R 38 syain_no = .Cells(R, 4) 39 simei = .Cells(R, 5) 40 honbu = .Cells(R, 6) 41 bu = .Cells(R, 7) 42 ka = .Cells(R, 8) 43 kakari = .Cells(R, 9) 44 koyo_keitai = .Cells(R, 10) 45 syokusyou = .Cells(R, 11) 46 kakuzuke1 = .Cells(R, 12) 47 kakuzuke2 = .Cells(R, 13) 48 yakusyoku = .Cells(R, 14) 49 End With 50 51 Set rcd = wS3.Range("a:a").Find(syain_no, lookat:=xlWhole) 52 If Not rcd Is Nothing Then 53 seibetu = rcd.Offset(0, 2) 54 seinengappi = rcd.Offset(0, 3) 55 nenrei = Age(seinengappi, today_d) 56 ketuekigata = rcd.Offset(0, 4) 57 nyusyabi = rcd.Offset(0, 5) 58 kinzokunensuu = Age(nyusyabi, today_d) 59 yuubinbangou = rcd.Offset(0, 6) 60 jyuusyo = rcd.Offset(0, 7) 61 denwabangou = rcd.Offset(0, 8) 62 keitaibangou = rcd.Offset(0, 9) 63 mailadd = rcd.Offset(0, 10) 64 gakureki = rcd.Offset(0, 11) 65 kenpo_no = rcd.Offset(0, 12) 66 nenkin_no = rcd.Offset(0, 13) 67 kisonenkin_no = rcd.Offset(0, 14) 68 End If 69 70 With wS2 71 Set rcd_honbu = .Range("a:a").Find(honbu, lookat:=xlWhole) 72 Set rcd_bu = .Range("c:c").Find(bu, lookat:=xlWhole) 73 Set rcd_ka = .Range("e:e").Find(ka, lookat:=xlWhole) 74 Set rcd_kakari = .Range("g:g").Find(kakari, lookat:=xlWhole) 75 sosikicode = rcd_honbu.Offset(0, 1) * 1000000 + rcd_bu.Offset(0, 1) * 10000 + rcd_ka.Offset(0, 1) * 100 + rcd_kakari.Offset(0, 1) 76 77 Set rcd_koyo_keitai = .Range("j:j").Find(koyo_keitai, lookat:=xlWhole) 78 koyo_keitai_code = rcd_koyo_keitai.Offset(0, 1) 79 80 Set rcd_kakuzuke1 = .Range("m:m").Find(kakuzuke1, lookat:=xlWhole) 81 Set rcd_kakuzuke2 = .Range("o:o").Find(kakuzuke2, lookat:=xlWhole) 82 kakuzuke_code = rcd_kakuzuke1.Offset(0, 1) * 100 + rcd_kakuzuke2.Offset(0, 1) 83 84 Set rcd_yakusyoku = .Range("q:q").Find(yakusyoku, lookat:=xlWhole) 85 yakusyoku_code = rcd_yakusyoku.Offset(0, 1) 86 End With 87 88 Dim arr() As Variant 89 If (kubun <> 3 And str_d <= today_d And today_d <= end_d) Or (str_d <= today_d And end_d = 0) Then 90 ReDim Preserve arr(30, p) 91 arr(0, p) = no 92 arr(1, p) = syain_no 93 arr(2, p) = honbu 94 arr(3, p) = bu 95 arr(4, p) = ka 96 arr(5, p) = kakari 97 arr(6, p) = sosikicode 98 arr(7, p) = koyo_keitai 99 arr(8, p) = koyo_keitai_code 100 arr(9, p) = syokusyou 101 arr(10, p) = kakuzuke1 102 arr(11, p) = kakuzuke2 103 arr(12, p) = kakuzuke_code 104 arr(13, p) = yakusyoku 105 arr(14, p) = yakusyoku_code 106 arr(15, p) = simei 107 arr(16, p) = seibetu 108 arr(17, p) = seinengappi 109 arr(18, p) = nenrei 110 arr(19, p) = ketuekigata 111 arr(20, p) = nyusyabi 112 arr(21, p) = kinzokunensuu 113 arr(22, p) = yuubinbangou 114 arr(23, p) = jyuusyo 115 arr(24, p) = denwabangou 116 arr(25, p) = keitaibangou 117 arr(26, p) = mailadd 118 arr(27, p) = gakureki 119 arr(28, p) = kenpo_no 120 arr(29, p) = nenkin_no 121 arr(30, p) = kisonenkin_no 122 p = p + 1 123 End If 124 Next m 125 126 With wS4.Range("a3").Resize(p, 31) 127 .Value = Application.WorksheetFunction.Transpose(arr) 128 End With 129 130 n = wS4.Cells(Rows.Count, 1).End(xlUp).Row 131 Set rcd_sosiki_code = wS4.Range("2:2").Find("組織コード", lookat:=xlWhole) 132 Set rcd_koyo_keitai_code = wS4.Range("2:2").Find("雇用形態コード", lookat:=xlWhole) 133 Set rcd_kakuzuke_code = wS4.Range("2:2").Find("格付コード", lookat:=xlWhole) 134 Set rcd_yakusyoku_code = wS4.Range("2:2").Find("役職コード", lookat:=xlWhole) 135 136 With wS4 137 .Sort.SortFields.Clear 138 .Sort.SortFields.Add Key:=rcd_sosiki_code, Order:=xlAscending 139 .Sort.SortFields.Add Key:=rcd_koyo_keitai_code, Order:=xlAscending 140 .Sort.SortFields.Add Key:=rcd_yakusyoku_code, Order:=xlAscending 141 .Sort.SortFields.Add Key:=rcd_kakuzuke_code, Order:=xlAscending 142 .Sort.SetRange .Range("A2:ae" & n) 143 .Sort.Header = xlYes 144 .Sort.Apply 145 End With 146 147 wS4.Range("A2:ae" & n).Borders.LineStyle = xlContinuous 148 wS4.Range("a1") = d & "現在社員名簿" 149 150End Sub 151 152Function Age(FromDate As Variant, ToDate As Variant) As Integer 153 Dim intAge As Integer 154 intAge = Year(ToDate) - Year(FromDate) 155 If Format(ToDate, "mmdd") < Format(FromDate, "mmdd") Then 156 intAge = intAge - 1 157 End If 158 Age = intAge 159End Function
0 コメント