teratail
回答率
85.47%
質問するログイン新規登録
トップVBAに関する質問条件に応じたデータ転記　ExcelVBA

編集履歴

回答編集履歴

3

ついき２

2019/03/07 09:23

投稿

jawa
jawa

スコア3013

test CHANGED
@@ -78,7 +78,7 @@
78
78
 
79
79
  ---
80
80
 
81
- ご自身で作成されたコードが提示されましたので、私からもサンプルコードを提供いたします。
81
+ 解決済みですが、ご自身で作成されたコードが提示されましたので、私からもサンプルコードを提供いたします。
82
82
 
83
83
  ※ttyp03さんのアドバイスを参考に、メンテナンス性を考慮する案を盛り込んだものです。
84
84
 

2

追記

2019/03/07 09:23

投稿

jawa
jawa

スコア3013

test CHANGED
@@ -69,3 +69,251 @@
69
69
  わからないことを（自分で調べたことも含めて）質問していただければ、お力添えできると思います。
70
70
 
71
71
  がんばってみてください。
72
+
73
+
74
+
75
+
76
+
77
+ （追記：2019/03/07　18：00）
78
+
79
+ ---
80
+
81
+ ご自身で作成されたコードが提示されましたので、私からもサンプルコードを提供いたします。
82
+
83
+ ※ttyp03さんのアドバイスを参考に、メンテナンス性を考慮する案を盛り込んだものです。
84
+
85
+
86
+
87
+ ```
88
+
89
+ 'コピー元の列番号
90
+
91
+ Enum ReadCols
92
+
93
+ 番号 = 1
94
+
95
+ 性
96
+
97
+ 名
98
+
99
+ セイ
100
+
101
+ メイ
102
+
103
+ 申請1
104
+
105
+ 申請2
106
+
107
+ 支社
108
+
109
+ 部署
110
+
111
+ チェック
112
+
113
+ 承認
114
+
115
+ End Enum
116
+
117
+
118
+
119
+ 'コピー先の列番号
120
+
121
+ Enum WriteCols
122
+
123
+ 番号 = 1
124
+
125
+ 性
126
+
127
+ 名
128
+
129
+ フリガナ
130
+
131
+ 支社
132
+
133
+ 申請1
134
+
135
+ 申請2
136
+
137
+
138
+
139
+ LAST
140
+
141
+ End Enum
142
+
143
+
144
+
145
+ Sub test()
146
+
147
+ Dim srcws As Worksheet
148
+
149
+ Dim dstws As Worksheet
150
+
151
+ Dim i As Long
152
+
153
+ Dim iCol As Integer
154
+
155
+
156
+
157
+ Dim dstrow As Long
158
+
159
+ Dim srcrow As Long
160
+
161
+
162
+
163
+ On Error GoTo ErrorHandler
164
+
165
+ Set srcws = Worksheets("元データ")
166
+
167
+ Set dstws = Worksheets("管理簿")
168
+
169
+
170
+
171
+ '管理簿最終行を求める
172
+
173
+ dstrow = dstws.Range("A" & Rows.Count).End(xlUp).Row + 1
174
+
175
+ '元データ最終行を求める
176
+
177
+ srcrow = srcws.Range("A" & Rows.Count).End(xlUp).Row
178
+
179
+
180
+
181
+ '出力先の各セルについて、コピー元の列を設定する
182
+
183
+ Dim dstcoltbl(100) As Long
184
+
185
+ Call DefineColumns(dstcoltbl)
186
+
187
+
188
+
189
+ '元データ行ループ
190
+
191
+ For i = 2 To srcrow
192
+
193
+
194
+
195
+ If srcws.Cells(i, ReadCols.承認).Value = "承認" Then
196
+
197
+ If srcws.Cells(i, ReadCols.チェック).Value = "" Then
198
+
199
+
200
+
201
+ '出力先1列目～最終列までループ処理
202
+
203
+ For iCol = 1 To WriteCols.LAST - 1
204
+
205
+ If dstcoltbl(iCol) <> 0 Then
206
+
207
+ dstws.Cells(dstrow, iCol).Value = srcws.Cells(i, dstcoltbl(iCol)).Value
208
+
209
+ Else
210
+
211
+ '加工する項目
212
+
213
+ Select Case iCol
214
+
215
+ Case WriteCols.フリガナ
216
+
217
+ dstws.Cells(dstrow, iCol).Value = StrConv(srcws.Cells(srcrow, ReadCols.セイ).Value & "　" & srcws.Cells(srcrow, ReadCols.メイ).Value, vbWide)
218
+
219
+ Case WriteCols.支社
220
+
221
+ dstws.Cells(dstrow, iCol).Value = StrConv(srcws.Cells(srcrow, ReadCols.支社).Value & srcws.Cells(srcrow, ReadCols.部署).Value, vbWide)
222
+
223
+ Case WriteCols.申請1
224
+
225
+ If (srcws.Cells(i, ReadCols.申請1).Value) = "必要" Then
226
+
227
+ dstws.Cells(dstrow, iCol).Value = srcws.Cells(i, ReadCols.申請1).Value
228
+
229
+ Else
230
+
231
+ dstws.Cells(dstrow, iCol).Value = ""
232
+
233
+ End If
234
+
235
+ Case WriteCols.申請2
236
+
237
+ If (srcws.Cells(i, ReadCols.申請2).Value) = "必要" Then
238
+
239
+ dstws.Cells(dstrow, iCol).Value = srcws.Cells(i, ReadCols.申請2).Value
240
+
241
+ Else
242
+
243
+ dstws.Cells(dstrow, iCol).Value = ""
244
+
245
+ End If
246
+
247
+ Case Else
248
+
249
+ '処理方法が見つからない列は空欄で出力
250
+
251
+ dstws.Cells(dstrow, iCol).Value = ""
252
+
253
+ End Select
254
+
255
+ End If
256
+
257
+ Next
258
+
259
+
260
+
261
+ '出力先の行番号をインクリメント
262
+
263
+ dstrow = dstrow + 1
264
+
265
+
266
+
267
+ End If
268
+
269
+ End If
270
+
271
+
272
+
273
+ Next
274
+
275
+
276
+
277
+ '罫線を引く
278
+
279
+ dstws.UsedRange.Borders.LineStyle = True
280
+
281
+
282
+
283
+ Exit Sub
284
+
285
+
286
+
287
+ ErrorHandler:
288
+
289
+ MsgBox "元データを追加してください。"
290
+
291
+
292
+
293
+ End Sub
294
+
295
+
296
+
297
+ 'コピー元の列を設定する関数
298
+
299
+ Private Sub DefineColumns(ByRef rColsTbl() As Long)
300
+
301
+ 'あえて項目毎に１：１で書いてみた。管理しやすければこれもアリ。
302
+
303
+ rColsTbl(WriteCols.番号) = ReadCols.番号
304
+
305
+ rColsTbl(WriteCols.性) = ReadCols.性
306
+
307
+ rColsTbl(WriteCols.名) = ReadCols.名
308
+
309
+ rColsTbl(WriteCols.フリガナ) = 0 '加工
310
+
311
+ rColsTbl(WriteCols.支社) = 0 '加工
312
+
313
+ rColsTbl(WriteCols.申請1) = 0 '加工
314
+
315
+ rColsTbl(WriteCols.申請2) = 0 '加工
316
+
317
+ End Sub
318
+
319
+ ```

1

しゅうせい

2019/03/07 09:18

投稿

jawa
jawa

スコア3013

test CHANGED
@@ -3,6 +3,8 @@
3
3
  慣れないうちはよく陥ることなのですが、全体ばかりを見てしまうと途方もない大物に思えて最初の一歩が踏み出せなくなります。
4
4
 
5
5
 
6
+
7
+ ---
6
8
 
7
9
  大事なのは最終的に実現したいものを、細かな機能にわけて、１つずつ着実に実装していくことです。
8
10
 
@@ -48,15 +50,19 @@
48
50
 
49
51
 
50
52
 
53
+ まずは①～③の機能を作ってみます。
54
+
51
- まずは①～③の機能を実装することで、単純に右から左へ無条件に転記する機能ができあがります。
55
+ これが実装できると、単純に右から左へ無条件に転記する機能ができあがります。
56
+
57
+
52
58
 
53
59
  そこに④⑤のような元の値を加工して出力する機能、⑥のような条件によって異なる値を出力する機能を実装します。
54
60
 
55
- さらに⑦⑧のような条件によっては元データの行を読み飛ばす機能を実装すれば、やりたいことはすべて実装されると思います。
61
+ さらに⑦⑧のような条件によっては元データの行を読み飛ばす機能を実装すれば、やりたいことがすべて実装されていると思います。
56
62
 
57
63
 
58
64
 
59
-
65
+ ---
60
66
 
61
67
  段階を追って、ひとつずつクリアしていく中で「これの実現方法が調べてもわからない」といったことがわかってくれば、それは大きな進歩です。
62
68