teratail
回答率
85.46%
質問するログイン新規登録
トップに関する質問共有サーバ上のブックからデータを転記する

編集履歴

質問編集履歴

8

不要箇所削除

2020/10/05 08:19

投稿

stinky
stinky

スコア2

test CHANGED
File without changes
test CHANGED
@@ -136,10 +136,6 @@
136
136
 
137
137
  Dim tmpint As Variant, dataTable As Range, myRange As Range, i As Long
138
138
 
139
- Dim fieldList()
140
-
141
- Dim rangeList()
142
-
143
139
  Dim wb As Workbook, ws As Worksheet
144
140
 
145
141
  Dim myPath As String, fn As String

7

誤字修正

2020/10/05 08:19

投稿

stinky
stinky

スコア2

test CHANGED
File without changes
test CHANGED
@@ -110,17 +110,17 @@
110
110
 
111
111
 
112
112
 
113
- ThisWorkbook.Worksheets("見積入力フォーム").Range("A4").Value = myRange.Cells(7).Value 'ブック2フィルターされた7列目をブック1A4に転記
113
+ ThisWorkbook.Worksheets("入力フォーム").Range("A4").Value = myRange.Cells(7).Value 'ブック2フィルターされた7列目をブック1A4に転記
114
-
114
+
115
- ThisWorkbook.Worksheets("見積入力フォーム").Range("C9").Value = myRange.Cells(36).Value 'ブック2フィルターされた36列目をブック1C9に転記
115
+ ThisWorkbook.Worksheets("入力フォーム").Range("C9").Value = myRange.Cells(36).Value 'ブック2フィルターされた36列目をブック1C9に転記
116
-
116
+
117
- ThisWorkbook.Worksheets("見積入力フォーム").Range("C11").Value = myRange.Cells(35).Value 'ブック2フィルターされた35列目をブック1C11に転記
117
+ ThisWorkbook.Worksheets("入力フォーム").Range("C11").Value = myRange.Cells(35).Value 'ブック2フィルターされた35列目をブック1C11に転記
118
-
118
+
119
- ThisWorkbook.Worksheets("見積入力フォーム").Range("K12").Value = myRange.Cells(34).Value 'ブック2フィルターされた34列目をブック1K12に転記
119
+ ThisWorkbook.Worksheets("入力フォーム").Range("K12").Value = myRange.Cells(34).Value 'ブック2フィルターされた34列目をブック1K12に転記
120
-
120
+
121
- ThisWorkbook.Worksheets("見積入力フォーム").Range("K13").Value = myRange.Cells(38).Value 'ブック2フィルターされた38列目をブック1K13に転記
121
+ ThisWorkbook.Worksheets("入力フォーム").Range("K13").Value = myRange.Cells(38).Value 'ブック2フィルターされた38列目をブック1K13に転記
122
-
122
+
123
- ThisWorkbook.Worksheets("見積入力フォーム").Range("F13").Value = myRange.Cells(39).Value 'ブック2フィルターされた39列目をブック1F13に転記
123
+ ThisWorkbook.Worksheets("入力フォーム").Range("F13").Value = myRange.Cells(39).Value 'ブック2フィルターされた39列目をブック1F13に転記
124
124
 
125
125
  ```
126
126
 
@@ -212,6 +212,124 @@
212
212
 
213
213
 
214
214
 
215
+ '検索値でオートフィルタ（ブック２データシート）
216
+
217
+ dataTable.AutoFilter 1, tmpint
218
+
219
+
220
+
221
+ '検索値がなければメッセージを表示して処理を抜ける
222
+
223
+ Set myRange = dataTable.SpecialCells(xlCellTypeVisible)
224
+
225
+ If myRange.Cells.Count = myRange.Columns.Count Then
226
+
227
+
228
+
229
+ MsgBox "該当するレコードはありませんでした"
230
+
231
+
232
+
233
+ dataTable.AutoFilter
234
+
235
+ Exit Sub
236
+
237
+ End If
238
+
239
+
240
+
241
+ '見出し行を除いた可視セル範囲を取得
242
+
243
+ Set myRange = Application.Intersect(dataTable.SpecialCells(xlCellTypeVisible), dataTable.Rows("2:" & dataTable.Rows.Count))
244
+
245
+
246
+
247
+ ThisWorkbook.Worksheets("入力フォーム").Range("A4").Value = myRange.Cells(7).Value 'ブック2フィルターされた7列目をブック1A4に転記
248
+
249
+ ThisWorkbook.Worksheets("入力フォーム").Range("C9").Value = myRange.Cells(36).Value 'ブック2フィルターされた36列目をブック1C9に転記
250
+
251
+ ThisWorkbook.Worksheets("入力フォーム").Range("C11").Value = myRange.Cells(35).Value 'ブック2フィルターされた35列目をブック1C11に転記
252
+
253
+ ThisWorkbook.Worksheets("入力フォーム").Range("K12").Value = myRange.Cells(34).Value 'ブック2フィルターされた34列目をブック1K12に転記
254
+
255
+ ThisWorkbook.Worksheets("入力フォーム").Range("K13").Value = myRange.Cells(38).Value 'ブック2フィルターされた38列目をブック1K13に転記
256
+
257
+ ThisWorkbook.Worksheets("入力フォーム").Range("F13").Value = myRange.Cells(39).Value 'ブック2フィルターされた39列目をブック1F13に転記
258
+
259
+
260
+
261
+ 'フィルターをかけた後、ブック２の見出し除くセルN3からAG最下行を選択
262
+
263
+ With ws
264
+
265
+ With ws.Range("A1").CurrentRegion
266
+
267
+ j = .Rows.Count
268
+
269
+ .Range(.Cells(3, 14), .Cells(j, 33)).Copy
270
+
271
+ End With
272
+
273
+ End With
274
+
275
+ 'ブック１のセルB16に貼りつけ
276
+
277
+ ThisWorkbook.Worksheets("入力フォーム").Range("B16").PasteSpecial (xlPasteValues)
278
+
279
+
280
+
281
+ dataTable.AutoFilter 'フィルタ解除
282
+
283
+ wb.Close False
284
+
285
+ Application.ScreenUpdating = True
286
+
287
+
288
+
289
+ End Sub
290
+
291
+ ```
292
+
293
+
294
+
295
+ ### 試したこと
296
+
297
+
298
+
299
+ 以下コードのように、ブックを１つで２シート（入力フォームシート、データシートシート）での作成では呼び出し（転記）ができました。
300
+
301
+ ですがブックを２つに分けた際上記の問題がでてしまいます。
302
+
303
+ ブック名：入力フォーム.xlsm、シート名：sheet1="入力フォーム"、sheet2="データシート"
304
+
305
+
306
+
307
+ ```
308
+
309
+ Sub 呼び出し()
310
+
311
+ Dim tmpint As Variant, dataTable As Range, myRange As Range, i As Long
312
+
313
+ Dim fieldList(), rangeList()
314
+
315
+ '検索値のセット
316
+
317
+ tmpint = Sheets("入力フォーム").Range("J1").Text
318
+
319
+ '検索元テーブルセット（range"データシート"は名前の定義）
320
+
321
+ Set dataTable = Sheets("データシート").Range("データシート")
322
+
323
+ '転記したいフィールド（データシートsheet）を指定
324
+
325
+ fieldList = Array(9, 10, 11, 12)
326
+
327
+ '転記先（入力フォームsheet）のセル位置を指定
328
+
329
+ rangeList = Array("B12", "C12", "D12", "E12")
330
+
331
+
332
+
215
333
  '検索値でオートフィルタ
216
334
 
217
335
  dataTable.AutoFilter 1, tmpint
@@ -244,156 +362,38 @@
244
362
 
245
363
 
246
364
 
365
+ Range("I9").Value = myRange.Cells(2).Value 'ﾃﾞｰﾀｼｰﾄ２列目を入力ﾌｫｰﾑI9に転記
366
+
367
+ Range("I6").Value = myRange.Cells(3).Value 'ﾃﾞｰﾀｼｰﾄ３列目を入力ﾌｫｰﾑI6に転記
368
+
369
+ Range("I7").Value = myRange.Cells(4).Value 'ﾃﾞｰﾀｼｰﾄ４列目を入力ﾌｫｰﾑI7に転記
370
+
371
+ Range("I1").Value = myRange.Cells(5).Value 'ﾃﾞｰﾀｼｰﾄ５列目を入力ﾌｫｰﾑI1に転記
372
+
247
- ThisWorkbook.Worksheets("見積入力フォーム").Range("A4").Value = myRange.Cells(7).Value 'ブック2フィルターされた7列目をブック1A4に転記
373
+ Range("C4").Value = myRange.Cells(6).Value 'ﾃﾞｰﾀｼｰﾄ６列目を入力ﾌｫｰﾑC4に転記
248
-
374
+
249
- ThisWorkbook.Worksheets("見積入力フォーム").Range("C9").Value = myRange.Cells(36).Value 'ブック2フィルターされた36列目をブック1C9に転記
375
+ Range("C5").Value = myRange.Cells(7).Value 'ﾃﾞｰﾀｼｰﾄ７列目を入力ﾌｫｰﾑC5に転記
250
-
376
+
251
- ThisWorkbook.Worksheets("見積入力フォーム").Range("C11").Value = myRange.Cells(35).Value 'ブック2フィルターされた35列目をブック1C11に転記
377
+ Range("C6").Value = myRange.Cells(8).Value 'ﾃﾞｰﾀｼｰﾄ８列目を入力ﾌｫｰﾑC6に転記
252
-
253
- ThisWorkbook.Worksheets("見積入力フォーム").Range("K12").Value = myRange.Cells(34).Value 'ブック2フィルターされた34列目をブック1K12に転記
378
+
254
-
255
- ThisWorkbook.Worksheets("見積入力フォーム").Range("K13").Value = myRange.Cells(38).Value 'ブック2フィルターされた38列目をブック1K13に転記
379
+
256
-
257
- ThisWorkbook.Worksheets("見積入力フォーム").Range("F13").Value = myRange.Cells(39).Value 'ブック2フィルターされた39列目をブック1F13に転記
380
+
258
-
259
-
260
-
261
- 'フィルターをかけた後、ブック２の見出し除くセルN3からAG最下行を選択
381
+ '指定したﾌｨｰﾙﾄﾞ（ﾃﾞｰﾀｼｰﾄsheet）を指定したｾﾙ位置（入力ﾌｫｰﾑsheet）に転記
262
-
263
- With ws
382
+
264
-
265
- With ws.Range("A1").CurrentRegion
266
-
267
- j = .Rows.Count
383
+ For i = 0 To UBound(fieldList)
268
-
384
+
269
- .Range(.Cells(3, 14), .Cells(j, 33)).Copy
385
+ myRange.Columns(fieldList(i)).Copy Range(rangeList(i))
270
-
386
+
387
+
388
+
271
- End With
389
+ Next
272
-
273
- End With
274
-
275
- 'ブック１のセルB16に貼りつけ
276
-
277
- ThisWorkbook.Worksheets("見積入力フォーム").Range("B16").PasteSpecial (xlPasteValues)
278
-
279
-
280
390
 
281
391
  dataTable.AutoFilter 'フィルタ解除
282
392
 
283
- wb.Close False
284
-
285
- Application.ScreenUpdating = True
286
-
287
393
 
288
394
 
289
395
  End Sub
290
396
 
291
- ```
292
-
293
-
294
-
295
- ### 試したこと
296
-
297
-
298
-
299
- 以下コードのように、ブックを１つで２シート（入力フォームシート、データシートシート）での作成では呼び出し（転記）ができました。
300
-
301
- ですがブックを２つに分けた際上記の問題がでてしまいます。
302
-
303
- ブック名：入力フォーム.xlsm、シート名：sheet1="入力フォーム"、sheet2="データシート"
304
-
305
-
306
-
307
- ```
308
-
309
- Sub 呼び出し()
310
-
311
- Dim tmpint As Variant, dataTable As Range, myRange As Range, i As Long
312
-
313
- Dim fieldList(), rangeList()
314
-
315
- '検索値のセット
316
-
317
- tmpint = Sheets("入力フォーム").Range("J1").Text
318
-
319
- '検索元テーブルセット（range"データシート"は名前の定義）
320
-
321
- Set dataTable = Sheets("データシート").Range("データシート")
322
-
323
- '転記したいフィールド（データシートsheet）を指定
324
-
325
- fieldList = Array(9, 10, 11, 12)
326
-
327
- '転記先（入力フォームsheet）のセル位置を指定
328
-
329
- rangeList = Array("B12", "C12", "D12", "E12")
330
-
331
-
332
-
333
- '検索値でオートフィルタ
334
-
335
- dataTable.AutoFilter 1, tmpint
336
-
337
-
338
-
339
- '検索値がなければメッセージを表示して処理を抜ける
340
-
341
- Set myRange = dataTable.SpecialCells(xlCellTypeVisible)
342
-
343
- If myRange.Cells.Count = myRange.Columns.Count Then
344
-
345
-
346
-
347
- MsgBox "該当するレコードはありませんでした"
348
-
349
-
350
-
351
- dataTable.AutoFilter
352
-
353
- Exit Sub
354
-
355
- End If
356
-
357
-
358
-
359
- '見出し行を除いた可視セル範囲を取得
360
-
361
- Set myRange = Application.Intersect(dataTable.SpecialCells(xlCellTypeVisible), dataTable.Rows("2:" & dataTable.Rows.Count))
362
-
363
-
364
-
365
- Range("I9").Value = myRange.Cells(2).Value 'ﾃﾞｰﾀｼｰﾄ２列目を入力ﾌｫｰﾑI9に転記
366
-
367
- Range("I6").Value = myRange.Cells(3).Value 'ﾃﾞｰﾀｼｰﾄ３列目を入力ﾌｫｰﾑI6に転記
368
-
369
- Range("I7").Value = myRange.Cells(4).Value 'ﾃﾞｰﾀｼｰﾄ４列目を入力ﾌｫｰﾑI7に転記
370
-
371
- Range("I1").Value = myRange.Cells(5).Value 'ﾃﾞｰﾀｼｰﾄ５列目を入力ﾌｫｰﾑI1に転記
372
-
373
- Range("C4").Value = myRange.Cells(6).Value 'ﾃﾞｰﾀｼｰﾄ６列目を入力ﾌｫｰﾑC4に転記
374
-
375
- Range("C5").Value = myRange.Cells(7).Value 'ﾃﾞｰﾀｼｰﾄ７列目を入力ﾌｫｰﾑC5に転記
376
-
377
- Range("C6").Value = myRange.Cells(8).Value 'ﾃﾞｰﾀｼｰﾄ８列目を入力ﾌｫｰﾑC6に転記
378
-
379
-
380
-
381
- '指定したﾌｨｰﾙﾄﾞ（ﾃﾞｰﾀｼｰﾄsheet）を指定したｾﾙ位置（入力ﾌｫｰﾑsheet）に転記
382
-
383
- For i = 0 To UBound(fieldList)
384
-
385
- myRange.Columns(fieldList(i)).Copy Range(rangeList(i))
386
-
387
-
388
-
389
- Next
390
-
391
- dataTable.AutoFilter 'フィルタ解除
392
-
393
-
394
-
395
- End Sub
396
-
397
397
  コード
398
398
 
399
399
  ```

6

情報修正

2020/10/05 08:15

投稿

stinky
stinky

スコア2

test CHANGED
File without changes
test CHANGED
@@ -92,132 +92,268 @@
92
92
 
93
93
 
94
94
 
95
- rangeListやThisWorkbook.Worksheet.Arrayの箇所でエラーが発生します。
95
+ ブック２からブック１へ転記する際、フィルターをかけ見出し以外を選択したいですが、見出し部分が転記されてしまいます。
96
-
96
+
97
+
98
+
97
- ブック１を指定できず適切なコードが分からないです。
99
+ エラーが発生せずどこが原因か分からないでいます。
98
-
100
+
99
- ここ以下のコードは進めないため未検証な状態です。申し訳ございません。
101
+ おそらく以下コードが原因だと推測してるのですが、躓いています。
100
-
101
-
102
-
102
+
103
+
104
+
103
- 他に、このコードを実行するたびに、タスクマネージャーのバックグラウンドプロセスのエクセルが増えてしまいます。エクセルを閉じても増えた分はバックグラウンドプロセスに残ったままです。
105
+ ```
104
-
106
+
105
- ※５回このコードを実行するとバックグラウンドプロセスに6個（元1個+実行5個）でき、エクセルを閉じても５個残ったまま（元1個は消える）。
107
+ '見出し行を除いた可視セル範囲を選択
106
-
107
-
108
-
108
+
109
- これはExcelApp.QuitやWb.Closeで回避できるのでしょうか。もしくは現在作り途中のエラーが出る中途半端なコードであり、適切なコードであれば解消されるのでしょうか。
109
+ Set myRange = Application.Intersect(dataTable.SpecialCells(xlCellTypeVisible), dataTable.Rows("2:" & dataTable.Rows.Count))
110
+
111
+
112
+
113
+ ThisWorkbook.Worksheets("見積入力フォーム").Range("A4").Value = myRange.Cells(7).Value 'ブック2フィルターされた7列目をブック1A4に転記
114
+
115
+ ThisWorkbook.Worksheets("見積入力フォーム").Range("C9").Value = myRange.Cells(36).Value 'ブック2フィルターされた36列目をブック1C9に転記
116
+
117
+ ThisWorkbook.Worksheets("見積入力フォーム").Range("C11").Value = myRange.Cells(35).Value 'ブック2フィルターされた35列目をブック1C11に転記
118
+
119
+ ThisWorkbook.Worksheets("見積入力フォーム").Range("K12").Value = myRange.Cells(34).Value 'ブック2フィルターされた34列目をブック1K12に転記
120
+
121
+ ThisWorkbook.Worksheets("見積入力フォーム").Range("K13").Value = myRange.Cells(38).Value 'ブック2フィルターされた38列目をブック1K13に転記
122
+
123
+ ThisWorkbook.Worksheets("見積入力フォーム").Range("F13").Value = myRange.Cells(39).Value 'ブック2フィルターされた39列目をブック1F13に転記
124
+
125
+ ```
110
126
 
111
127
 
112
128
 
113
129
  ### 該当のソースコード
114
130
 
115
-
131
+ 全コード
116
132
 
117
133
  ```
118
134
 
119
135
  Sub 呼び出し()
120
136
 
137
+ Dim tmpint As Variant, dataTable As Range, myRange As Range, i As Long
138
+
139
+ Dim fieldList()
140
+
141
+ Dim rangeList()
142
+
143
+ Dim wb As Workbook, ws As Worksheet
144
+
145
+ Dim myPath As String, fn As String
146
+
147
+ Dim j As Long
148
+
149
+
150
+
151
+ myPath = "\共有サーバ\"
152
+
153
+ fn = "データシート.xlsm"
154
+
155
+
156
+
157
+ '自PCで（データシート）が開いていたら閉じる
158
+
159
+ On Error Resume Next
160
+
161
+ Set wb = Workbooks(fn)
162
+
163
+ On Error GoTo 0
164
+
165
+ If Not wb Is Nothing Then
166
+
167
+ wb.Close False
168
+
169
+ End If
170
+
171
+
172
+
173
+ Application.DisplayAlerts = False
174
+
175
+ Set wb = Workbooks.Open(Filename:=myPath & fn, Notify:=False)
176
+
177
+ Application.DisplayAlerts = True
178
+
179
+
180
+
181
+ If wb.ReadOnly Then
182
+
183
+ MsgBox "他の人が作業中です。しばらく経ってから呼び出しし直してください。"
184
+
185
+ wb.Close False
186
+
187
+ Exit Sub
188
+
189
+ Else
190
+
191
+ Set ws = wb.Sheets("データシート")
192
+
193
+ wb.Activate
194
+
195
+ ws.Activate
196
+
197
+ End If
198
+
199
+
200
+
201
+ Application.ScreenUpdating = False
202
+
203
+
204
+
205
+ '検索値のセット（ブック１入力フォーム）
206
+
207
+ tmpint = ThisWorkbook.Worksheets("入力フォーム").Range("J1").Text
208
+
209
+ '検索元テーブルセット（データシートの名前の定義"データシート"）
210
+
211
+ Set dataTable = wb.ws.Range("データシート")
212
+
213
+
214
+
215
+ '検索値でオートフィルタ
216
+
217
+ dataTable.AutoFilter 1, tmpint
218
+
219
+
220
+
221
+ '検索値がなければメッセージを表示して処理を抜ける
222
+
223
+ Set myRange = dataTable.SpecialCells(xlCellTypeVisible)
224
+
225
+ If myRange.Cells.Count = myRange.Columns.Count Then
226
+
227
+
228
+
229
+ MsgBox "該当するレコードはありませんでした"
230
+
231
+
232
+
233
+ dataTable.AutoFilter
234
+
235
+ Exit Sub
236
+
237
+ End If
238
+
239
+
240
+
241
+ '見出し行を除いた可視セル範囲を取得
242
+
243
+ Set myRange = Application.Intersect(dataTable.SpecialCells(xlCellTypeVisible), dataTable.Rows("2:" & dataTable.Rows.Count))
244
+
245
+
246
+
247
+ ThisWorkbook.Worksheets("見積入力フォーム").Range("A4").Value = myRange.Cells(7).Value 'ブック2フィルターされた7列目をブック1A4に転記
248
+
249
+ ThisWorkbook.Worksheets("見積入力フォーム").Range("C9").Value = myRange.Cells(36).Value 'ブック2フィルターされた36列目をブック1C9に転記
250
+
251
+ ThisWorkbook.Worksheets("見積入力フォーム").Range("C11").Value = myRange.Cells(35).Value 'ブック2フィルターされた35列目をブック1C11に転記
252
+
253
+ ThisWorkbook.Worksheets("見積入力フォーム").Range("K12").Value = myRange.Cells(34).Value 'ブック2フィルターされた34列目をブック1K12に転記
254
+
255
+ ThisWorkbook.Worksheets("見積入力フォーム").Range("K13").Value = myRange.Cells(38).Value 'ブック2フィルターされた38列目をブック1K13に転記
256
+
257
+ ThisWorkbook.Worksheets("見積入力フォーム").Range("F13").Value = myRange.Cells(39).Value 'ブック2フィルターされた39列目をブック1F13に転記
258
+
259
+
260
+
261
+ 'フィルターをかけた後、ブック２の見出し除くセルN3からAG最下行を選択
262
+
263
+ With ws
264
+
265
+ With ws.Range("A1").CurrentRegion
266
+
267
+ j = .Rows.Count
268
+
269
+ .Range(.Cells(3, 14), .Cells(j, 33)).Copy
270
+
271
+ End With
272
+
273
+ End With
274
+
275
+ 'ブック１のセルB16に貼りつけ
276
+
277
+ ThisWorkbook.Worksheets("見積入力フォーム").Range("B16").PasteSpecial (xlPasteValues)
278
+
279
+
280
+
281
+ dataTable.AutoFilter 'フィルタ解除
282
+
283
+ wb.Close False
284
+
285
+ Application.ScreenUpdating = True
286
+
287
+
288
+
289
+ End Sub
290
+
291
+ ```
292
+
293
+
294
+
295
+ ### 試したこと
296
+
297
+
298
+
299
+ 以下コードのように、ブックを１つで２シート（入力フォームシート、データシートシート）での作成では呼び出し（転記）ができました。
300
+
301
+ ですがブックを２つに分けた際上記の問題がでてしまいます。
302
+
303
+ ブック名：入力フォーム.xlsm、シート名：sheet1="入力フォーム"、sheet2="データシート"
304
+
305
+
306
+
307
+ ```
308
+
309
+ Sub 呼び出し()
310
+
121
311
  Dim tmpint As Variant, dataTable As Range, myRange As Range, i As Long
122
312
 
123
- Dim fieldList()
313
+ Dim fieldList(), rangeList()
124
-
314
+
125
- Dim rangeList()
315
+ '検索値のセット
316
+
126
-
317
+ tmpint = Sheets("入力フォーム").Range("J1").Text
318
+
319
+ '検索元テーブルセット（range"データシート"は名前の定義）
320
+
321
+ Set dataTable = Sheets("データシート").Range("データシート")
322
+
127
- Dim wb As Workbook, ws As Worksheet
323
+ '転記したいフィールド（データシートsheet）を指定
128
-
324
+
129
- Dim myPath As String, fn As String
325
+ fieldList = Array(9, 10, 11, 12)
326
+
130
-
327
+ '転記先（入力フォームsheet）のセル位置を指定
328
+
131
-
329
+ rangeList = Array("B12", "C12", "D12", "E12")
330
+
331
+
332
+
132
-
333
+ '検索値でオートフィルタ
334
+
133
- myPath = "\共有サーバ\"
335
+ dataTable.AutoFilter 1, tmpint
336
+
337
+
338
+
134
-
339
+ '検索値がなければメッセージを表示して処理を抜ける
340
+
341
+ Set myRange = dataTable.SpecialCells(xlCellTypeVisible)
342
+
343
+ If myRange.Cells.Count = myRange.Columns.Count Then
344
+
345
+
346
+
135
- fn = "データシート.xlsm"
347
+ MsgBox "該当するレコードはありませんでした"
136
-
137
-
138
-
139
- '自PCで（データシート）が開いていたら閉じる
348
+
140
-
141
- On Error Resume Next
349
+
142
-
143
- Set wb = Workbooks(fn)
350
+
144
-
145
- On Error GoTo 0
146
-
147
- If Not wb Is Nothing Then
148
-
149
- wb.Close False
150
-
151
- End If
152
-
153
-
154
-
155
- Application.DisplayAlerts = False
156
-
157
- Set wb = Workbooks.Open(Filename:=myPath & fn, Notify:=False)
158
-
159
- Application.DisplayAlerts = True
160
-
161
-
162
-
163
- If wb.ReadOnly Then
351
+ dataTable.AutoFilter
164
-
165
- MsgBox "他の人が作業中です。しばらく経ってから呼び出しし直してください。"
166
-
167
- wb.Close False
168
352
 
169
353
  Exit Sub
170
354
 
171
- Else
172
-
173
- Set ws = wb.Sheets("データシート")
174
-
175
- wb.Activate
176
-
177
- ws.Activate
178
-
179
355
  End If
180
356
 
181
-
182
-
183
- tmpint = ThisWorkbook.Worksheets("入力フォーム").Range("J1").Text '検索値のセット
184
-
185
- Set dataTable = wb.ws.Range("データシート") '検索元テーブルセット
186
-
187
- '転記したいフィールドを指定（ブック２）
188
-
189
- fieldList = Array(14, 15, 16, 17, 18, 20, 21, 22, 23, 24, 26, 27, 28, 29, 30, 31, 32, 33)
190
-
191
- '転記先のセル位置を指定（ブック１）
192
-
193
- rangeList = ThisWorkbook.Worksheet.Array("B16", "C16", "D16", "E16", "F16", "H16", "I16", "J16", "K16", "L16", "N16", "O16", "P16", "Q16", "R16", "S16", "T16", "U16")
194
-
195
-
196
-
197
- '検索値でオートフィルタ
198
-
199
- dataTable.AutoFilter 1, tmpint
200
-
201
-
202
-
203
- '検索値がなければメッセージを表示して処理を抜ける
204
-
205
- Set myRange = dataTable.SpecialCells(xlCellTypeVisible)
206
-
207
- If myRange.Cells.Count = myRange.Columns.Count Then
208
-
209
-
210
-
211
- MsgBox "該当するレコードはありませんでした"
212
-
213
-
214
-
215
- dataTable.AutoFilter
216
-
217
- Exit Sub
218
-
219
- End If
220
-
221
357
 
222
358
 
223
359
  '見出し行を除いた可視セル範囲を取得
@@ -226,29 +362,29 @@
226
362
 
227
363
 
228
364
 
229
- Range("B2").Value = myRange.Cells(2).Value '日時を転記
365
+ Range("I9").Value = myRange.Cells(2).Value 'ﾃﾞｰﾀｼｰﾄ２列目を入力ﾌｫｰﾑI9に転記
366
+
230
-
367
+ Range("I6").Value = myRange.Cells(3).Value 'ﾃﾞｰﾀｼｰﾄ３列目を入力ﾌｫｰﾑI6に転記
368
+
369
+ Range("I7").Value = myRange.Cells(4).Value 'ﾃﾞｰﾀｼｰﾄ４列目を入力ﾌｫｰﾑI7に転記
370
+
371
+ Range("I1").Value = myRange.Cells(5).Value 'ﾃﾞｰﾀｼｰﾄ５列目を入力ﾌｫｰﾑI1に転記
372
+
231
- Range("A4").Value = myRange.Cells(7).Value 'コードを転記
373
+ Range("C4").Value = myRange.Cells(6).Value 'ﾃﾞｰﾀｼｰﾄ６列目を入力ﾌｫｰﾑC4に転記
232
-
374
+
233
- Range("C9").Value = myRange.Cells(35).Value '場所を転記
375
+ Range("C5").Value = myRange.Cells(7).Value 'ﾃﾞｰﾀｼｰﾄ７列目を入力ﾌｫｰﾑC5に転記
234
-
235
- Range("C11").Value = myRange.Cells(34).Value 'メモを転記
376
+
236
-
237
- Range("K12").Value = myRange.Cells(33).Value 'ユーザを転記
238
-
239
- Range("K13").Value = myRange.Cells(37).Value 'フラグを転記
240
-
241
- Range("F13").Value = myRange.Cells(38).Value '手数料を転記
377
+ Range("C6").Value = myRange.Cells(8).Value 'ﾃﾞｰﾀｼｰﾄ８列目を入力ﾌｫｰﾑC6に転記
242
-
243
-
244
-
378
+
379
+
380
+
245
- '指定したフィールドを指定したセル位置に転記
381
+ '指定したﾌｨｰﾙﾄﾞ（ﾃﾞｰﾀｼｰﾄsheet）を指定したｾﾙ位置（入力ﾌｫｰﾑsheet）に転記
246
382
 
247
383
  For i = 0 To UBound(fieldList)
248
384
 
249
385
  myRange.Columns(fieldList(i)).Copy Range(rangeList(i))
250
386
 
251
-
387
+
252
388
 
253
389
  Next
254
390
 
@@ -258,112 +394,6 @@
258
394
 
259
395
  End Sub
260
396
 
261
- ```
262
-
263
-
264
-
265
- ### 試したこと
266
-
267
-
268
-
269
- 以下コードのように、ブックを１つで２シート（入力フォームシート、データシートシート）での作成では呼び出し（転記）ができました。
270
-
271
- ですがブックを２つに分けた際上記の問題がでてしまいます。
272
-
273
- ブック名：入力フォーム.xlsm、シート名：sheet1="入力フォーム"、sheet2="データシート"
274
-
275
-
276
-
277
- ```
278
-
279
- Sub 呼び出し()
280
-
281
- Dim tmpint As Variant, dataTable As Range, myRange As Range, i As Long
282
-
283
- Dim fieldList(), rangeList()
284
-
285
- '検索値のセット
286
-
287
- tmpint = Sheets("入力フォーム").Range("J1").Text
288
-
289
- '検索元テーブルセット（range"データシート"は名前の定義）
290
-
291
- Set dataTable = Sheets("データシート").Range("データシート")
292
-
293
- '転記したいフィールド（データシートsheet）を指定
294
-
295
- fieldList = Array(9, 10, 11, 12)
296
-
297
- '転記先（入力フォームsheet）のセル位置を指定
298
-
299
- rangeList = Array("B12", "C12", "D12", "E12")
300
-
301
-
302
-
303
- '検索値でオートフィルタ
304
-
305
- dataTable.AutoFilter 1, tmpint
306
-
307
-
308
-
309
- '検索値がなければメッセージを表示して処理を抜ける
310
-
311
- Set myRange = dataTable.SpecialCells(xlCellTypeVisible)
312
-
313
- If myRange.Cells.Count = myRange.Columns.Count Then
314
-
315
-
316
-
317
- MsgBox "該当するレコードはありませんでした"
318
-
319
-
320
-
321
- dataTable.AutoFilter
322
-
323
- Exit Sub
324
-
325
- End If
326
-
327
-
328
-
329
- '見出し行を除いた可視セル範囲を取得
330
-
331
- Set myRange = Application.Intersect(dataTable.SpecialCells(xlCellTypeVisible), dataTable.Rows("2:" & dataTable.Rows.Count))
332
-
333
-
334
-
335
- Range("I9").Value = myRange.Cells(2).Value 'ﾃﾞｰﾀｼｰﾄ２列目を入力ﾌｫｰﾑI9に転記
336
-
337
- Range("I6").Value = myRange.Cells(3).Value 'ﾃﾞｰﾀｼｰﾄ３列目を入力ﾌｫｰﾑI6に転記
338
-
339
- Range("I7").Value = myRange.Cells(4).Value 'ﾃﾞｰﾀｼｰﾄ４列目を入力ﾌｫｰﾑI7に転記
340
-
341
- Range("I1").Value = myRange.Cells(5).Value 'ﾃﾞｰﾀｼｰﾄ５列目を入力ﾌｫｰﾑI1に転記
342
-
343
- Range("C4").Value = myRange.Cells(6).Value 'ﾃﾞｰﾀｼｰﾄ６列目を入力ﾌｫｰﾑC4に転記
344
-
345
- Range("C5").Value = myRange.Cells(7).Value 'ﾃﾞｰﾀｼｰﾄ７列目を入力ﾌｫｰﾑC5に転記
346
-
347
- Range("C6").Value = myRange.Cells(8).Value 'ﾃﾞｰﾀｼｰﾄ８列目を入力ﾌｫｰﾑC6に転記
348
-
349
-
350
-
351
- '指定したﾌｨｰﾙﾄﾞ（ﾃﾞｰﾀｼｰﾄsheet）を指定したｾﾙ位置（入力ﾌｫｰﾑsheet）に転記
352
-
353
- For i = 0 To UBound(fieldList)
354
-
355
- myRange.Columns(fieldList(i)).Copy Range(rangeList(i))
356
-
357
-
358
-
359
- Next
360
-
361
- dataTable.AutoFilter 'フィルタ解除
362
-
363
-
364
-
365
- End Sub
366
-
367
397
  コード
368
398
 
369
399
  ```

5

間違い箇所修正

2020/10/05 08:07

投稿

stinky
stinky

スコア2

test CHANGED
File without changes
test CHANGED
@@ -114,7 +114,9 @@
114
114
 
115
115
 
116
116
 
117
+ ```
118
+
117
- ```Sub 呼び出し()
119
+ Sub 呼び出し()
118
120
 
119
121
  Dim tmpint As Variant, dataTable As Range, myRange As Range, i As Long
120
122
 
@@ -256,112 +258,112 @@
256
258
 
257
259
  End Sub
258
260
 
261
+ ```
262
+
263
+
264
+
265
+ ### 試したこと
266
+
267
+
268
+
269
+ 以下コードのように、ブックを１つで２シート（入力フォームシート、データシートシート）での作成では呼び出し（転記）ができました。
270
+
271
+ ですがブックを２つに分けた際上記の問題がでてしまいます。
272
+
273
+ ブック名：入力フォーム.xlsm、シート名：sheet1="入力フォーム"、sheet2="データシート"
274
+
275
+
276
+
277
+ ```
278
+
279
+ Sub 呼び出し()
280
+
281
+ Dim tmpint As Variant, dataTable As Range, myRange As Range, i As Long
282
+
283
+ Dim fieldList(), rangeList()
284
+
285
+ '検索値のセット
286
+
287
+ tmpint = Sheets("入力フォーム").Range("J1").Text
288
+
289
+ '検索元テーブルセット（range"データシート"は名前の定義）
290
+
291
+ Set dataTable = Sheets("データシート").Range("データシート")
292
+
293
+ '転記したいフィールド（データシートsheet）を指定
294
+
295
+ fieldList = Array(9, 10, 11, 12)
296
+
297
+ '転記先（入力フォームsheet）のセル位置を指定
298
+
299
+ rangeList = Array("B12", "C12", "D12", "E12")
300
+
301
+
302
+
303
+ '検索値でオートフィルタ
304
+
305
+ dataTable.AutoFilter 1, tmpint
306
+
307
+
308
+
309
+ '検索値がなければメッセージを表示して処理を抜ける
310
+
311
+ Set myRange = dataTable.SpecialCells(xlCellTypeVisible)
312
+
313
+ If myRange.Cells.Count = myRange.Columns.Count Then
314
+
315
+
316
+
317
+ MsgBox "該当するレコードはありませんでした"
318
+
319
+
320
+
321
+ dataTable.AutoFilter
322
+
323
+ Exit Sub
324
+
325
+ End If
326
+
327
+
328
+
329
+ '見出し行を除いた可視セル範囲を取得
330
+
331
+ Set myRange = Application.Intersect(dataTable.SpecialCells(xlCellTypeVisible), dataTable.Rows("2:" & dataTable.Rows.Count))
332
+
333
+
334
+
335
+ Range("I9").Value = myRange.Cells(2).Value 'ﾃﾞｰﾀｼｰﾄ２列目を入力ﾌｫｰﾑI9に転記
336
+
337
+ Range("I6").Value = myRange.Cells(3).Value 'ﾃﾞｰﾀｼｰﾄ３列目を入力ﾌｫｰﾑI6に転記
338
+
339
+ Range("I7").Value = myRange.Cells(4).Value 'ﾃﾞｰﾀｼｰﾄ４列目を入力ﾌｫｰﾑI7に転記
340
+
341
+ Range("I1").Value = myRange.Cells(5).Value 'ﾃﾞｰﾀｼｰﾄ５列目を入力ﾌｫｰﾑI1に転記
342
+
343
+ Range("C4").Value = myRange.Cells(6).Value 'ﾃﾞｰﾀｼｰﾄ６列目を入力ﾌｫｰﾑC4に転記
344
+
345
+ Range("C5").Value = myRange.Cells(7).Value 'ﾃﾞｰﾀｼｰﾄ７列目を入力ﾌｫｰﾑC5に転記
346
+
347
+ Range("C6").Value = myRange.Cells(8).Value 'ﾃﾞｰﾀｼｰﾄ８列目を入力ﾌｫｰﾑC6に転記
348
+
349
+
350
+
351
+ '指定したﾌｨｰﾙﾄﾞ（ﾃﾞｰﾀｼｰﾄsheet）を指定したｾﾙ位置（入力ﾌｫｰﾑsheet）に転記
352
+
353
+ For i = 0 To UBound(fieldList)
354
+
355
+ myRange.Columns(fieldList(i)).Copy Range(rangeList(i))
356
+
357
+
358
+
359
+ Next
360
+
361
+ dataTable.AutoFilter 'フィルタ解除
362
+
363
+
364
+
365
+ End Sub
366
+
259
367
  コード
260
368
 
261
369
  ```
262
-
263
-
264
-
265
- ### 試したこと
266
-
267
-
268
-
269
- 以下コードのように、ブックを１つで２シート（入力フォームシート、データシートシート）での作成では呼び出し（転記）ができました。
270
-
271
- ですがブックを２つに分けた際上記の問題がでてしまいます。
272
-
273
- ブック名：入力フォーム.xlsm、シート名：sheet1="入力フォーム"、sheet2="データシート"
274
-
275
-
276
-
277
- ```Sub 呼び出し()
278
-
279
- Dim tmpint As Variant, dataTable As Range, myRange As Range, i As Long
280
-
281
- Dim fieldList(), rangeList()
282
-
283
- '検索値のセット
284
-
285
- tmpint = Sheets("入力フォーム").Range("J1").Text
286
-
287
- '検索元テーブルセット（range"データシート"は名前の定義）
288
-
289
- Set dataTable = Sheets("データシート").Range("データシート")
290
-
291
- '転記したいフィールド（データシートsheet）を指定
292
-
293
- fieldList = Array(9, 10, 11, 12)
294
-
295
- '転記先（入力フォームsheet）のセル位置を指定
296
-
297
- rangeList = Array("B12", "C12", "D12", "E12")
298
-
299
-
300
-
301
- '検索値でオートフィルタ
302
-
303
- dataTable.AutoFilter 1, tmpint
304
-
305
-
306
-
307
- '検索値がなければメッセージを表示して処理を抜ける
308
-
309
- Set myRange = dataTable.SpecialCells(xlCellTypeVisible)
310
-
311
- If myRange.Cells.Count = myRange.Columns.Count Then
312
-
313
-
314
-
315
- MsgBox "該当するレコードはありませんでした"
316
-
317
-
318
-
319
- dataTable.AutoFilter
320
-
321
- Exit Sub
322
-
323
- End If
324
-
325
-
326
-
327
- '見出し行を除いた可視セル範囲を取得
328
-
329
- Set myRange = Application.Intersect(dataTable.SpecialCells(xlCellTypeVisible), dataTable.Rows("2:" & dataTable.Rows.Count))
330
-
331
-
332
-
333
- Range("I9").Value = myRange.Cells(2).Value 'ﾃﾞｰﾀｼｰﾄ２列目を入力ﾌｫｰﾑI9に転記
334
-
335
- Range("I6").Value = myRange.Cells(3).Value 'ﾃﾞｰﾀｼｰﾄ３列目を入力ﾌｫｰﾑI6に転記
336
-
337
- Range("I7").Value = myRange.Cells(4).Value 'ﾃﾞｰﾀｼｰﾄ４列目を入力ﾌｫｰﾑI7に転記
338
-
339
- Range("I1").Value = myRange.Cells(5).Value 'ﾃﾞｰﾀｼｰﾄ５列目を入力ﾌｫｰﾑI1に転記
340
-
341
- Range("C4").Value = myRange.Cells(6).Value 'ﾃﾞｰﾀｼｰﾄ６列目を入力ﾌｫｰﾑC4に転記
342
-
343
- Range("C5").Value = myRange.Cells(7).Value 'ﾃﾞｰﾀｼｰﾄ７列目を入力ﾌｫｰﾑC5に転記
344
-
345
- Range("C6").Value = myRange.Cells(8).Value 'ﾃﾞｰﾀｼｰﾄ８列目を入力ﾌｫｰﾑC6に転記
346
-
347
-
348
-
349
- '指定したﾌｨｰﾙﾄﾞ（ﾃﾞｰﾀｼｰﾄsheet）を指定したｾﾙ位置（入力ﾌｫｰﾑsheet）に転記
350
-
351
- For i = 0 To UBound(fieldList)
352
-
353
- myRange.Columns(fieldList(i)).Copy Range(rangeList(i))
354
-
355
-
356
-
357
- Next
358
-
359
- dataTable.AutoFilter 'フィルタ解除
360
-
361
-
362
-
363
- End Sub
364
-
365
- コード
366
-
367
- ```

4

情報追記

2020/10/02 13:49

投稿

stinky
stinky

スコア2

test CHANGED
File without changes
test CHANGED
@@ -22,7 +22,7 @@
22
22
 
23
23
  ・ブック１からブック２へデータを転記し蓄積するたび、ブック２は以下コードで定義を更新しています。
24
24
 
25
- wb.Names("データシート").RefersTo = ws.Range("データシート").CurrentRegion
25
+ ```wb.Names("データシート").RefersTo = ws.Range("データシート").CurrentRegion
26
26
 
27
27
  wb.Activate
28
28
 
@@ -38,6 +38,10 @@
38
38
 
39
39
  wb.Close False
40
40
 
41
+ コード
42
+
43
+ ```
44
+
41
45
 
42
46
 
43
47
  利用手順
@@ -178,9 +182,13 @@
178
182
 
179
183
  Set dataTable = wb.ws.Range("データシート") '検索元テーブルセット
180
184
 
185
+ '転記したいフィールドを指定（ブック２）
186
+
181
- fieldList = Array(14, 15, 16, 17, 18, 20, 21, 22, 23, 24, 26, 27, 28, 29, 30, 31, 32, 33) '転記したいフィールドを指定
187
+ fieldList = Array(14, 15, 16, 17, 18, 20, 21, 22, 23, 24, 26, 27, 28, 29, 30, 31, 32, 33)
188
+
182
-
189
+ '転記先のセル位置を指定（ブック１）
190
+
183
- rangeList = ThisWorkbook.Worksheet.Array("B16", "C16", "D16", "E16", "F16", "H16", "I16", "J16", "K16", "L16", "N16", "O16", "P16", "Q16", "R16", "S16", "T16", "U16") '転記先のセル位置を指定
191
+ rangeList = ThisWorkbook.Worksheet.Array("B16", "C16", "D16", "E16", "F16", "H16", "I16", "J16", "K16", "L16", "N16", "O16", "P16", "Q16", "R16", "S16", "T16", "U16")
184
192
 
185
193
 
186
194
 
@@ -258,6 +266,102 @@
258
266
 
259
267
 
260
268
 
261
- ブックを１つで２シート（入力フォームシート、データシートシート）での作成では呼び出し（転記）ができました。
269
+ 以下コードのように、ブックを１つで２シート（入力フォームシート、データシートシート）での作成では呼び出し（転記）ができました。
262
270
 
263
271
  ですがブックを２つに分けた際上記の問題がでてしまいます。
272
+
273
+ ブック名：入力フォーム.xlsm、シート名：sheet1="入力フォーム"、sheet2="データシート"
274
+
275
+
276
+
277
+ ```Sub 呼び出し()
278
+
279
+ Dim tmpint As Variant, dataTable As Range, myRange As Range, i As Long
280
+
281
+ Dim fieldList(), rangeList()
282
+
283
+ '検索値のセット
284
+
285
+ tmpint = Sheets("入力フォーム").Range("J1").Text
286
+
287
+ '検索元テーブルセット（range"データシート"は名前の定義）
288
+
289
+ Set dataTable = Sheets("データシート").Range("データシート")
290
+
291
+ '転記したいフィールド（データシートsheet）を指定
292
+
293
+ fieldList = Array(9, 10, 11, 12)
294
+
295
+ '転記先（入力フォームsheet）のセル位置を指定
296
+
297
+ rangeList = Array("B12", "C12", "D12", "E12")
298
+
299
+
300
+
301
+ '検索値でオートフィルタ
302
+
303
+ dataTable.AutoFilter 1, tmpint
304
+
305
+
306
+
307
+ '検索値がなければメッセージを表示して処理を抜ける
308
+
309
+ Set myRange = dataTable.SpecialCells(xlCellTypeVisible)
310
+
311
+ If myRange.Cells.Count = myRange.Columns.Count Then
312
+
313
+
314
+
315
+ MsgBox "該当するレコードはありませんでした"
316
+
317
+
318
+
319
+ dataTable.AutoFilter
320
+
321
+ Exit Sub
322
+
323
+ End If
324
+
325
+
326
+
327
+ '見出し行を除いた可視セル範囲を取得
328
+
329
+ Set myRange = Application.Intersect(dataTable.SpecialCells(xlCellTypeVisible), dataTable.Rows("2:" & dataTable.Rows.Count))
330
+
331
+
332
+
333
+ Range("I9").Value = myRange.Cells(2).Value 'ﾃﾞｰﾀｼｰﾄ２列目を入力ﾌｫｰﾑI9に転記
334
+
335
+ Range("I6").Value = myRange.Cells(3).Value 'ﾃﾞｰﾀｼｰﾄ３列目を入力ﾌｫｰﾑI6に転記
336
+
337
+ Range("I7").Value = myRange.Cells(4).Value 'ﾃﾞｰﾀｼｰﾄ４列目を入力ﾌｫｰﾑI7に転記
338
+
339
+ Range("I1").Value = myRange.Cells(5).Value 'ﾃﾞｰﾀｼｰﾄ５列目を入力ﾌｫｰﾑI1に転記
340
+
341
+ Range("C4").Value = myRange.Cells(6).Value 'ﾃﾞｰﾀｼｰﾄ６列目を入力ﾌｫｰﾑC4に転記
342
+
343
+ Range("C5").Value = myRange.Cells(7).Value 'ﾃﾞｰﾀｼｰﾄ７列目を入力ﾌｫｰﾑC5に転記
344
+
345
+ Range("C6").Value = myRange.Cells(8).Value 'ﾃﾞｰﾀｼｰﾄ８列目を入力ﾌｫｰﾑC6に転記
346
+
347
+
348
+
349
+ '指定したﾌｨｰﾙﾄﾞ（ﾃﾞｰﾀｼｰﾄsheet）を指定したｾﾙ位置（入力ﾌｫｰﾑsheet）に転記
350
+
351
+ For i = 0 To UBound(fieldList)
352
+
353
+ myRange.Columns(fieldList(i)).Copy Range(rangeList(i))
354
+
355
+
356
+
357
+ Next
358
+
359
+ dataTable.AutoFilter 'フィルタ解除
360
+
361
+
362
+
363
+ End Sub
364
+
365
+ コード
366
+
367
+ ```

3

情報追記

2020/10/02 09:15

投稿

stinky
stinky

スコア2

test CHANGED
File without changes
test CHANGED
@@ -14,11 +14,29 @@
14
14
 
15
15
  仕様として、２つブックを用意し、１つは入力フォーム、２つ目はデータ蓄積のデータベースブック。
16
16
 
17
- ブック１＝ブック名：入力フォーム.xlsm、シート名：入力フォーム
17
+ ・ブック１＝ブック名：入力フォーム.xlsm、シート名：入力フォーム
18
-
18
+
19
- ブック２＝ブック名：データシート.xlsm、シート名：データシート
19
+ ・ブック２＝ブック名：データシート.xlsm、シート名：データシート
20
-
20
+
21
- ブック１はコピーし複数人で利用します。（複数の入力フォームブックで作成したデータを、逐一データベース用のブックに蓄積していき、必要に応じて呼び出す）
21
+ ・ブック１はコピーし複数人で利用します。（複数の入力フォームブックで作成したデータを、逐一データベース用のブックに蓄積していき、必要に応じて呼び出す）
22
+
23
+ ・ブック１からブック２へデータを転記し蓄積するたび、ブック２は以下コードで定義を更新しています。
24
+
25
+ wb.Names("データシート").RefersTo = ws.Range("データシート").CurrentRegion
26
+
27
+ wb.Activate
28
+
29
+ ws.Select
30
+
31
+ ws.Cells(ws.Rows.Count, 2).End(xlUp).Offset(1, 0).Select
32
+
33
+ Application.DisplayAlerts = False
34
+
35
+ wb.Save
36
+
37
+ Application.DisplayAlerts = True
38
+
39
+ wb.Close False
22
40
 
23
41
 
24
42
 
@@ -52,6 +70,8 @@
52
70
 
53
71
  ↓【ブック２"データシート.xlsm"、シート名"データシート"】　蓄積されたデータシート
54
72
 
73
+ 　蓄積範囲A2～AM＊は増えた分名前の定義を更新しています。名前定義：データシート
74
+
55
75
  ![イメージ説明](5dd298ae34fdf3736cb9fc8effb40ae9.jpeg)
56
76
 
57
77
 

2

情報追記

2020/10/02 08:33

投稿

stinky
stinky

スコア2

test CHANGED
File without changes
test CHANGED
@@ -14,7 +14,11 @@
14
14
 
15
15
  仕様として、２つブックを用意し、１つは入力フォーム、２つ目はデータ蓄積のデータベースブック。
16
16
 
17
+ ブック１＝ブック名：入力フォーム.xlsm、シート名：入力フォーム
18
+
19
+ ブック２＝ブック名：データシート.xlsm、シート名：データシート
20
+
17
- 入力フォームブックはコピーし複数人で利用します。（複数の入力フォームブックで作成したデータを、逐一データベース用のブックに蓄積していき、必要に応じて呼び出す）
21
+ ブック１はコピーし複数人で利用します。（複数の入力フォームブックで作成したデータを、逐一データベース用のブックに蓄積していき、必要に応じて呼び出す）
18
22
 
19
23
 
20
24
 
@@ -46,13 +50,13 @@
46
50
 
47
51
 
48
52
 
49
- ↓【ブック２】　蓄積されたデータシート
53
+ ↓【ブック２"データシート.xlsm"、シート名"データシート"】　蓄積されたデータシート
50
54
 
51
55
  ![イメージ説明](5dd298ae34fdf3736cb9fc8effb40ae9.jpeg)
52
56
 
53
57
 
54
58
 
55
- ↓【ブック１】　呼び出し後のイメージ
59
+ ↓【ブック１"入力フォーム.xlsm"、シート名"入力フォーム"】　呼び出し後のイメージ
56
60
 
57
61
  ![イメージ説明](e0589875eeae3b31794ff0a3ab4d9a1d.jpeg)
58
62
 

1

不要箇所削除

2020/10/02 07:50

投稿

stinky
stinky

スコア2

test CHANGED
File without changes
test CHANGED
@@ -154,9 +154,9 @@
154
154
 
155
155
  Set dataTable = wb.ws.Range("データシート") '検索元テーブルセット
156
156
 
157
- fieldList = Array(14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33) '転記したいフィールドを指定
157
+ fieldList = Array(14, 15, 16, 17, 18, 20, 21, 22, 23, 24, 26, 27, 28, 29, 30, 31, 32, 33) '転記したいフィールドを指定
158
-
158
+
159
- rangeList = ThisWorkbook.Worksheet.Array("B16", "C16", "D16", "E16", "F16", "G16", "H16", "I16", "J16", "K16", "L16", "M16", "N16", "O16", "P16", "Q16", "R16", "S16", "T16", "U16") '転記先のセル位置を指定
159
+ rangeList = ThisWorkbook.Worksheet.Array("B16", "C16", "D16", "E16", "F16", "H16", "I16", "J16", "K16", "L16", "N16", "O16", "P16", "Q16", "R16", "S16", "T16", "U16") '転記先のセル位置を指定
160
160
 
161
161
 
162
162