teratail
回答率
85.31%
teratail header banner
teratail header banner
質問するログイン新規登録
トップVBAに関する質問【VBA】列がたくさんある表をコピーする際のOffsetの設定方法を知りたい

編集履歴

質問編集履歴

2

コードを修正。

2023/01/26 03:04

投稿

koburon
koburon

スコア31

test CHANGED
File without changes
test CHANGED
@@ -18,15 +18,21 @@
18
18
  ![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2023-01-24/1eb81e31-fc1c-4745-9b01-b1b5bef5dc70.jpeg)
19
19
  ### 該当のソースコード
20
20
  現在の社員名簿を出力するVBAコードです。
21
+ ※(1/26追記)文字数制限のため、ソースコードを修正しました。
21
22
  ```VBA
22
23
  Sub meibokosin(d As Date, c As Collection)
23
24
 
24
25
  Dim kubun As Integer, today_d As Date, str_d As Date, end_d As Date
25
- Dim no As Integer, syain_no As Integer, honbu As String, bu As String, ka As String, kakari As String, sosikicode As Long, _
26
+ Dim no As Integer, syain_no As Long, honbu As String, bu As String, ka As String, kakari As String, sosikicode As Long, _
26
27
  koyo_keitai As String, koyo_keitai_code As Integer, syokusyou As String, kakuzuke1 As String, kakuzuke2 As String, kakuzuke_code As Long, _
27
28
  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, _
28
29
  kinzokunensuu As Integer, yuubinbangou As String, jyuusyo As String, denwabangou As String, keitaibangou As String, _
29
- mailadd As String, gakureki As String, kenpo_no As Integer, nenkin_no As Integer, kisonenkin_no As String
30
+ mailadd As String, gakureki As String, kenpo_no As String, nenkin_no As String, kisonenkin_no As String
31
+ Dim honbucode As Long, syozoku As String, syozoku_code As Long
32
+
33
+ Const AddCol As Long = 128 '追加列数
34
+ Dim aval(AddCol - 1) As Variant '追加列分格納領域
35
+ Dim i As Long '添え字
30
36
 
31
37
  Dim wS1 As Worksheet
32
38
  Dim wS2 As Worksheet
@@ -43,8 +49,8 @@
43
49
 
44
50
  n = wS4.Cells(Rows.Count, 1).End(xlUp).Row
45
51
  If n > 2 Then
46
- wS4.Range(Cells(3, 1), Cells(n, 31)).ClearContents
52
+ wS4.Range(Cells(3, 1), Cells(n, 162)).ClearContents
47
- wS4.Range(Cells(3, 1), Cells(n, 31)).Borders.LineStyle = xlLineStyleNone
53
+ wS4.Range(Cells(3, 1), Cells(n, 162)).Borders.LineStyle = xlLineStyleNone
48
54
  End If
49
55
 
50
56
 
@@ -67,6 +73,7 @@
67
73
  kakuzuke1 = .Cells(R, 12)
68
74
  kakuzuke2 = .Cells(R, 13)
69
75
  yakusyoku = .Cells(R, 14)
76
+ syozoku = .Cells(R, 15)
70
77
  End With
71
78
 
72
79
  Set rcd = wS3.Range("a:a").Find(syain_no, lookat:=xlWhole)
@@ -86,6 +93,11 @@
86
93
  kenpo_no = rcd.Offset(0, 12)
87
94
  nenkin_no = rcd.Offset(0, 13)
88
95
  kisonenkin_no = rcd.Offset(0, 14)
96
+
97
+ For i = 0 To UBound(aval)
98
+ aval(i) = rcd.Offset(0, 15 + i)
99
+ Next
100
+
89
101
  End If
90
102
 
91
103
  With wS2
@@ -94,6 +106,7 @@
94
106
  Set rcd_ka = .Range("e:e").Find(ka, lookat:=xlWhole)
95
107
  Set rcd_kakari = .Range("g:g").Find(kakari, lookat:=xlWhole)
96
108
  sosikicode = rcd_honbu.Offset(0, 1) * 1000000 + rcd_bu.Offset(0, 1) * 10000 + rcd_ka.Offset(0, 1) * 100 + rcd_kakari.Offset(0, 1)
109
+ honbucode = rcd_honbu.Offset(0, 1)
97
110
 
98
111
  Set rcd_koyo_keitai = .Range("j:j").Find(koyo_keitai, lookat:=xlWhole)
99
112
  koyo_keitai_code = rcd_koyo_keitai.Offset(0, 1)
@@ -104,11 +117,15 @@
104
117
 
105
118
  Set rcd_yakusyoku = .Range("q:q").Find(yakusyoku, lookat:=xlWhole)
106
119
  yakusyoku_code = rcd_yakusyoku.Offset(0, 1)
120
+
121
+ Set rcd_syozoku = .Range("t:t").Find(syozoku, lookat:=xlWhole)
122
+ syozoku_code = rcd_syozoku.Offset(0, 1)
123
+
107
124
  End With
108
125
 
109
126
  Dim arr() As Variant
110
127
  If (kubun <> 3 And str_d <= today_d And today_d <= end_d) Or (str_d <= today_d And end_d = 0) Then
111
- ReDim Preserve arr(30, p)
128
+ ReDim Preserve arr(161, p)
112
129
  arr(0, p) = no
113
130
  arr(1, p) = syain_no
114
131
  arr(2, p) = honbu
@@ -140,11 +157,19 @@
140
157
  arr(28, p) = kenpo_no
141
158
  arr(29, p) = nenkin_no
142
159
  arr(30, p) = kisonenkin_no
160
+ arr(31, p) = honbucode
161
+ arr(32, p) = syozoku
162
+ arr(33, p) = syozoku_code
163
+
164
+ For i = 0 To UBound(aval)
165
+ arr(34 + i, p) = aval(i)
166
+ Next
167
+
143
168
  p = p + 1
144
169
  End If
145
170
  Next m
146
171
 
147
- With wS4.Range("a3").Resize(p, 31)
172
+ With wS4.Range("a3").Resize(p, 162)
148
173
  .Value = Application.WorksheetFunction.Transpose(arr)
149
174
  End With
150
175
 
@@ -156,28 +181,19 @@
156
181
 
157
182
  With wS4
158
183
  .Sort.SortFields.Clear
159
- .Sort.SortFields.Add Key:=rcd_sosiki_code, Order:=xlAscending
184
+ .Sort.SortFields.add Key:=rcd_sosiki_code, Order:=xlAscending
160
- .Sort.SortFields.Add Key:=rcd_koyo_keitai_code, Order:=xlAscending
185
+ .Sort.SortFields.add Key:=rcd_koyo_keitai_code, Order:=xlAscending
161
- .Sort.SortFields.Add Key:=rcd_yakusyoku_code, Order:=xlAscending
186
+ .Sort.SortFields.add Key:=rcd_yakusyoku_code, Order:=xlAscending
162
- .Sort.SortFields.Add Key:=rcd_kakuzuke_code, Order:=xlAscending
187
+ .Sort.SortFields.add Key:=rcd_kakuzuke_code, Order:=xlAscending
163
- .Sort.SetRange .Range("A2:ae" & n)
188
+ .Sort.SetRange .Range("A2:ff" & n)
164
189
  .Sort.Header = xlYes
165
190
  .Sort.Apply
166
191
  End With
167
192
 
168
- wS4.Range("A2:ae" & n).Borders.LineStyle = xlContinuous
193
+ wS4.Range("A2:ff" & n).Borders.LineStyle = xlContinuous
169
194
  wS4.Range("a1") = d & "現在社員名簿"
170
195
 
171
196
  End Sub
172
-
173
- Function Age(FromDate As Variant, ToDate As Variant) As Integer
174
- Dim intAge As Integer
175
- intAge = Year(ToDate) - Year(FromDate)
176
- If Format(ToDate, "mmdd") < Format(FromDate, "mmdd") Then
177
- intAge = intAge - 1
178
- End If
179
- Age = intAge
180
- End Function
181
197
  ```
182
198
 
183
199
  ### 実現したいこと
VBA

1

画像を追加。

2023/01/24 09:26

投稿

koburon
koburon

スコア31

test CHANGED
File without changes
test CHANGED
@@ -8,6 +8,14 @@
8
8
  0. 社員基本情報（生年月日やメールアドレス等、異動に関係ない項目）
9
9
  0. 現在の社員名簿（今日現在の社員情報をまとめたもの）
10
10
 
11
+ 【異動DB】
12
+ ![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2023-01-24/d75a674a-1143-46b8-b6cc-52031f268521.jpeg)
13
+ 【組織マスター】
14
+ ![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2023-01-24/f6545fc9-9319-4c15-a4ad-bcacbf8b03ac.jpeg)
15
+ 【社員基本情報】
16
+ ![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2023-01-24/4a9a85e0-2121-4ac8-aca7-9584a7e84621.jpeg)
17
+ 【現在の社員名簿】
18
+ ![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2023-01-24/1eb81e31-fc1c-4745-9b01-b1b5bef5dc70.jpeg)
11
19
  ### 該当のソースコード
12
20
  現在の社員名簿を出力するVBAコードです。
13
21
  ```VBA
VBA