Q&A
> 1つずつ追記する必要があるでしょうか。
規則性があるのであればループ処理にしてはどうでしょうか？
前提
Excelファイルを開くと、自動的に今日現在の社員名簿を出力するマクロを作っています。
ブックは1つで、以下の複数のシートを連携させて出力します。
下記の参考URLをベースに作成しています。
- 異動DB（異動年月日や異動先の部署をまとめたもの）
- 組織マスター（部署や役職等、異動に関する項目）
- 社員基本情報（生年月日やメールアドレス等、異動に関係ない項目）
- 現在の社員名簿（今日現在の社員情報をまとめたもの）
【異動DB】
【組織マスター】
【社員基本情報】
【現在の社員名簿】
該当のソースコード
現在の社員名簿を出力するVBAコードです。
※(1/26追記)文字数制限のため、ソースコードを修正しました。
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 Long, 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 String, nenkin_no As String, kisonenkin_no As String 9 Dim honbucode As Long, syozoku As String, syozoku_code As Long 10 11 Const AddCol As Long = 128 '追加列数 12 Dim aval(AddCol - 1) As Variant '追加列分格納領域 13 Dim i As Long '添え字 14 15 Dim wS1 As Worksheet 16 Dim wS2 As Worksheet 17 Dim wS3 As Worksheet 18 Dim wS4 As Worksheet 19 20 'ワークシートを変数で宣言する 21 Set wS1 = Worksheets("異動DB") 22 Set wS2 = Worksheets("組織マスター") 23 Set wS3 = Worksheets("社員基本情報") 24 Set wS4 = Worksheets("現在の社員名簿") 25 26 wS4.Activate 27 28 n = wS4.Cells(Rows.Count, 1).End(xlUp).Row 29 If n > 2 Then 30 wS4.Range(Cells(3, 1), Cells(n, 162)).ClearContents 31 wS4.Range(Cells(3, 1), Cells(n, 162)).Borders.LineStyle = xlLineStyleNone 32 End If 33 34 35 For m = 1 To c.Count 36 R = c(m) 37 With wS1 38 today_d = d 39 kubun = .Cells(R, 1) 40 str_d = .Cells(R, 2) 41 end_d = .Cells(R, 3) 42 no = R 43 syain_no = .Cells(R, 4) 44 simei = .Cells(R, 5) 45 honbu = .Cells(R, 6) 46 bu = .Cells(R, 7) 47 ka = .Cells(R, 8) 48 kakari = .Cells(R, 9) 49 koyo_keitai = .Cells(R, 10) 50 syokusyou = .Cells(R, 11) 51 kakuzuke1 = .Cells(R, 12) 52 kakuzuke2 = .Cells(R, 13) 53 yakusyoku = .Cells(R, 14) 54 syozoku = .Cells(R, 15) 55 End With 56 57 Set rcd = wS3.Range("a:a").Find(syain_no, lookat:=xlWhole) 58 If Not rcd Is Nothing Then 59 seibetu = rcd.Offset(0, 2) 60 seinengappi = rcd.Offset(0, 3) 61 nenrei = Age(seinengappi, today_d) 62 ketuekigata = rcd.Offset(0, 4) 63 nyusyabi = rcd.Offset(0, 5) 64 kinzokunensuu = Age(nyusyabi, today_d) 65 yuubinbangou = rcd.Offset(0, 6) 66 jyuusyo = rcd.Offset(0, 7) 67 denwabangou = rcd.Offset(0, 8) 68 keitaibangou = rcd.Offset(0, 9) 69 mailadd = rcd.Offset(0, 10) 70 gakureki = rcd.Offset(0, 11) 71 kenpo_no = rcd.Offset(0, 12) 72 nenkin_no = rcd.Offset(0, 13) 73 kisonenkin_no = rcd.Offset(0, 14) 74 75 For i = 0 To UBound(aval) 76 aval(i) = rcd.Offset(0, 15 + i) 77 Next 78 79 End If 80 81 With wS2 82 Set rcd_honbu = .Range("a:a").Find(honbu, lookat:=xlWhole) 83 Set rcd_bu = .Range("c:c").Find(bu, lookat:=xlWhole) 84 Set rcd_ka = .Range("e:e").Find(ka, lookat:=xlWhole) 85 Set rcd_kakari = .Range("g:g").Find(kakari, lookat:=xlWhole) 86 sosikicode = rcd_honbu.Offset(0, 1) * 1000000 + rcd_bu.Offset(0, 1) * 10000 + rcd_ka.Offset(0, 1) * 100 + rcd_kakari.Offset(0, 1) 87 honbucode = rcd_honbu.Offset(0, 1) 88 89 Set rcd_koyo_keitai = .Range("j:j").Find(koyo_keitai, lookat:=xlWhole) 90 koyo_keitai_code = rcd_koyo_keitai.Offset(0, 1) 91 92 Set rcd_kakuzuke1 = .Range("m:m").Find(kakuzuke1, lookat:=xlWhole) 93 Set rcd_kakuzuke2 = .Range("o:o").Find(kakuzuke2, lookat:=xlWhole) 94 kakuzuke_code = rcd_kakuzuke1.Offset(0, 1) * 100 + rcd_kakuzuke2.Offset(0, 1) 95 96 Set rcd_yakusyoku = .Range("q:q").Find(yakusyoku, lookat:=xlWhole) 97 yakusyoku_code = rcd_yakusyoku.Offset(0, 1) 98 99 Set rcd_syozoku = .Range("t:t").Find(syozoku, lookat:=xlWhole) 100 syozoku_code = rcd_syozoku.Offset(0, 1) 101 102 End With 103 104 Dim arr() As Variant 105 If (kubun <> 3 And str_d <= today_d And today_d <= end_d) Or (str_d <= today_d And end_d = 0) Then 106 ReDim Preserve arr(161, p) 107 arr(0, p) = no 108 arr(1, p) = syain_no 109 arr(2, p) = honbu 110 arr(3, p) = bu 111 arr(4, p) = ka 112 arr(5, p) = kakari 113 arr(6, p) = sosikicode 114 arr(7, p) = koyo_keitai 115 arr(8, p) = koyo_keitai_code 116 arr(9, p) = syokusyou 117 arr(10, p) = kakuzuke1 118 arr(11, p) = kakuzuke2 119 arr(12, p) = kakuzuke_code 120 arr(13, p) = yakusyoku 121 arr(14, p) = yakusyoku_code 122 arr(15, p) = simei 123 arr(16, p) = seibetu 124 arr(17, p) = seinengappi 125 arr(18, p) = nenrei 126 arr(19, p) = ketuekigata 127 arr(20, p) = nyusyabi 128 arr(21, p) = kinzokunensuu 129 arr(22, p) = yuubinbangou 130 arr(23, p) = jyuusyo 131 arr(24, p) = denwabangou 132 arr(25, p) = keitaibangou 133 arr(26, p) = mailadd 134 arr(27, p) = gakureki 135 arr(28, p) = kenpo_no 136 arr(29, p) = nenkin_no 137 arr(30, p) = kisonenkin_no 138 arr(31, p) = honbucode 139 arr(32, p) = syozoku 140 arr(33, p) = syozoku_code 141 142 For i = 0 To UBound(aval) 143 arr(34 + i, p) = aval(i) 144 Next 145 146 p = p + 1 147 End If 148 Next m 149 150 With wS4.Range("a3").Resize(p, 162) 151 .Value = Application.WorksheetFunction.Transpose(arr) 152 End With 153 154 n = wS4.Cells(Rows.Count, 1).End(xlUp).Row 155 Set rcd_sosiki_code = wS4.Range("2:2").Find("組織コード", lookat:=xlWhole) 156 Set rcd_koyo_keitai_code = wS4.Range("2:2").Find("雇用形態コード", lookat:=xlWhole) 157 Set rcd_kakuzuke_code = wS4.Range("2:2").Find("格付コード", lookat:=xlWhole) 158 Set rcd_yakusyoku_code = wS4.Range("2:2").Find("役職コード", lookat:=xlWhole) 159 160 With wS4 161 .Sort.SortFields.Clear 162 .Sort.SortFields.add Key:=rcd_sosiki_code, Order:=xlAscending 163 .Sort.SortFields.add Key:=rcd_koyo_keitai_code, Order:=xlAscending 164 .Sort.SortFields.add Key:=rcd_yakusyoku_code, Order:=xlAscending 165 .Sort.SortFields.add Key:=rcd_kakuzuke_code, Order:=xlAscending 166 .Sort.SetRange .Range("A2:ff" & n) 167 .Sort.Header = xlYes 168 .Sort.Apply 169 End With 170 171 wS4.Range("A2:ff" & n).Borders.LineStyle = xlContinuous 172 wS4.Range("a1") = d & "現在社員名簿" 173 174End Sub
実現したいこと
上記のコードで社員基本情報(wS3)は14行まで存在しますが、今回は、会社のSQLに存在する社員マスタの見出しに合わせて、wS3の列を増やし、現在の社員名簿(wS4)の列もその分増やしたいと考えています。
列の順番が入れ替わることは無いので、offset関数でそのままコピーしてwS4に貼り付けるイメージです。
試したこと
増やす列が5つくらいまでであれば、rcd.Offset(0, XXX)を手入力すれば済みますが、今回は50列まで増やす必要があり、入力する手間がかかってしまいます。
セル範囲をまとめて選択し、書き込むようにしたいですが、やはり面倒でもrcd.Offset(0, XXX) および arr(XXX,p)の部分を1つずつ追記する必要があるでしょうか。
少ないコードで済む設定について、ご教示いただければ幸いです。
よろしくお願いいたします。
補足情報（FW/ツールのバージョンなど）
PC：Windows11
ソフト：Microsoft365 Excel
参考URL：社員名簿を作る ～その1～
回答1件
0
ベストアンサー
社員基本情報が現在１５列まであり、５０列まで拡張すると理解しました。
よって追加する行は３５行となります。以下、その前提での回答です。
基本的には、配列を確保し、配列に３５列分を格納する方法です。
尚、こちらで環境を作成できませんでしたの、動作確認は行っておりませんので、
ご了承ください。
VBA
1以下の変数を追加 2 Const AddCol As Long = 35 '追加列数 3 Dim aval(AddCol - 1) As Variant '追加列分格納領域 4 Dim i As Long '添え字 5 6 767: kisonenkin_no = rcd.Offset(0, 14) 8の下へ以下の行を追加 9 For i = 0 To UBound(aval) 10 aval(i) = rcd.Offset(0, 15 + i) 11 Next 12 13121: arr(30, p) = kisonenkin_no 14の下へ以下の行を追加 15 For i = 0 To UBound(aval) 16 arr(31 + i, p) = aval(i) 17 Next 18 19 20以下の数値は適切な値に変更する必要があります。 21 2231を変更 2324: If n > 2 Then 2425: wS4.Range(Cells(3, 1), Cells(n, 31)).ClearContents 2526: wS4.Range(Cells(3, 1), Cells(n, 31)).Borders.LineStyle = xlLineStyleNone 2627: End If 27 2830を変更 2990: ReDim Preserve arr(30, p) 30 31 3231を変更 33126: With wS4.Range("a3").Resize(p, 31) 34127: .Value = Application.WorksheetFunction.Transpose(arr) 35128: End With 36
投稿2023/01/25 08:26
総合スコア5438
回答ありがとうございます。
いただいたコメントの通り35追加する場合で修正したところ、問題なく動作しました。
実はこの後、修正依頼があり、128列分追加する必要が出ました。
しかし同じように数値を変更して実行したところ、エラーは起きずに動作完了しましたが、追加列分のセルに値が全く入っていない、という問題が発生しました。
修正コード（Sub～End Subの部分）を追記したので、お手数ですがご確認いただき、間違っている部分がありましたらコメントいただけるでしょうか。恐らく値の数え間違えだとは思いますが…。
よろしくお願いいたします。
現行、出力対象列が３１列で、１２８列を追加すると１５９列になります。
wS4.Range(Cells(3, 1), Cells(n, 162)).ClearContents
wS4.Range(Cells(3, 1), Cells(n, 162)).Borders.LineStyle = xlLineStyleNone
With wS4.Range("a3").Resize(p, 162)
の１６２は１５９の誤りと思われます。
ReDim Preserve arr(161, p)の１６１は１５８が正しいかと。
上記の値に変更した場合は、どうなるでしょうか。
又、上記で、正常に動作しなかった場合、
下記の154行目のブレイクポイントを設定し、そこで止めたとき、
"現在の社員名簿"に値が設定されているか確認してください。
154行目以降で、"現在の社員名簿"の内容をクリアしている可能性も考えられますので。
154: n = wS4.Cells(Rows.Count, 1).End(xlUp).Row
念のための確認ですが、そもそも社員基本情報には１２８列分の追加列分のデータが設定されてますでしょうか。
社員基本情報の追加列のセルが空なら、現在の社員名簿への出力結果も空になります。
コメントありがとうございます。
元々ある社員基本情報の追加列のセルに値は入っています。
コードをもう一度確認したところ、ご指摘の通り、ReDimの数値の誤りが原因でした。
修正したところ、問題なく値が入りました。
お手数をおかけしました。
ベストアンサーとさせていただきます。
ありがとうございました。
あなたの回答
tips
プレビュー
