質問編集履歴
3
ソースコード全文記載
test
CHANGED
|
File without changes
|
test
CHANGED
|
@@ -32,9 +32,9 @@
|
|
|
32
32
|
|
|
33
33
|
```
|
|
34
34
|
|
|
35
|
-
転記元ファイルのファイル名は「◯◯◯_aaa.xlsx」となっており（◯は固定値）
|
|
35
|
+
**転記元ファイルのファイル名は「◯◯◯_aaa.xlsx」となっており（◯は固定値）
|
|
36
|
-
|
|
36
|
+
|
|
37
|
-
aaaの部分を一覧のD列に転記しているため、これをキーにソースコードを作成したのですが、うまくいきません。
|
|
37
|
+
aaaの部分を一覧のD列に転記しているため、これをキーにソースコードを作成したのですが、うまくいきません。**
|
|
38
38
|
|
|
39
39
|
|
|
40
40
|
|
|
@@ -50,11 +50,55 @@
|
|
|
50
50
|
|
|
51
51
|
|
|
52
52
|
|
|
53
|
+
Option Explicit
|
|
54
|
+
|
|
55
|
+
|
|
56
|
+
|
|
57
|
+
Dim mFSO As FileSystemObject
|
|
58
|
+
|
|
59
|
+
|
|
60
|
+
|
|
61
|
+
Sub 一覧表更新()
|
|
62
|
+
|
|
63
|
+
Dim rngList As Range
|
|
64
|
+
|
|
65
|
+
Dim vrtSubjectList As Variant
|
|
66
|
+
|
|
67
|
+
|
|
68
|
+
|
|
53
|
-
|
|
69
|
+
Set mFSO = New FileSystemObject
|
|
70
|
+
|
|
71
|
+
|
|
72
|
+
|
|
54
|
-
|
|
73
|
+
'一覧表のセル範囲取得
|
|
74
|
+
|
|
55
|
-
|
|
75
|
+
Set rngList = ThisWorkbook.Worksheets("一覧").Range("A12").CurrentRegion
|
|
76
|
+
|
|
77
|
+
|
|
78
|
+
|
|
56
|
-
|
|
79
|
+
'空欄クリア
|
|
80
|
+
|
|
81
|
+
InitializeTable rngList
|
|
82
|
+
|
|
83
|
+
|
|
84
|
+
|
|
85
|
+
'一覧にないファイルのリストを取得
|
|
86
|
+
|
|
87
|
+
vrtSubjectList = Get_UpdatedSubjectList(rngList)
|
|
88
|
+
|
|
89
|
+
|
|
90
|
+
|
|
91
|
+
'データの転記
|
|
92
|
+
|
|
93
|
+
SetUpdated vrtSubjectList, rngList
|
|
94
|
+
|
|
95
|
+
|
|
96
|
+
|
|
97
|
+
End Sub
|
|
98
|
+
|
|
99
|
+
|
|
100
|
+
|
|
57
|
-
'一覧のAQ列が空欄の行をクリア
|
|
101
|
+
'一覧表中のAQ列が空欄の行をクリア
|
|
58
102
|
|
|
59
103
|
Private Sub InitializeTable(ByRef rngList As Range)
|
|
60
104
|
|
|
@@ -90,6 +134,8 @@
|
|
|
90
134
|
|
|
91
135
|
|
|
92
136
|
|
|
137
|
+
'一覧表にないファイルのフルパスのリストを取得
|
|
138
|
+
|
|
93
139
|
Private Function Get_UpdatedSubjectList(ByRef rngList As Range) As Variant
|
|
94
140
|
|
|
95
141
|
Dim WSF As WorksheetFunction
|
|
@@ -160,7 +206,67 @@
|
|
|
160
206
|
|
|
161
207
|
|
|
162
208
|
|
|
209
|
+
'データの転記
|
|
210
|
+
|
|
211
|
+
Private Sub SetUpdated(ByVal vrtSubjectList As Variant, ByRef rngList As Range)
|
|
212
|
+
|
|
213
|
+
Dim c As Range
|
|
214
|
+
|
|
215
|
+
Dim f As Variant
|
|
216
|
+
|
|
217
|
+
Dim strContent(1 To 66) As String
|
|
218
|
+
|
|
219
|
+
Dim ix As Long
|
|
220
|
+
|
|
221
|
+
Dim vrtNewList() As Variant
|
|
222
|
+
|
|
223
|
+
ReDim vrtNewList(LBound(vrtSubjectList) To UBound(vrtSubjectList), 1 To 66)
|
|
224
|
+
|
|
225
|
+
|
|
226
|
+
|
|
227
|
+
For Each f In vrtSubjectList
|
|
228
|
+
|
|
229
|
+
ix = ix + 1
|
|
230
|
+
|
|
163
|
-
|
|
231
|
+
With Workbooks.Open(f, UpdateLinks:=False, ReadOnly:=True)
|
|
232
|
+
|
|
233
|
+
vrtNewList(ix, 1) = .Worksheets("単票").Cells(10, 33).Value
|
|
234
|
+
|
|
235
|
+
|
|
236
|
+
|
|
237
|
+
__（※こちらは文字数の制限により、省略致します※）__
|
|
238
|
+
|
|
239
|
+
|
|
240
|
+
|
|
241
|
+
vrtNewList(ix, 66) = .Worksheets("単票").Cells(2, 46).Value
|
|
242
|
+
|
|
243
|
+
|
|
244
|
+
|
|
245
|
+
.Close False
|
|
246
|
+
|
|
247
|
+
End With
|
|
248
|
+
|
|
249
|
+
Next
|
|
250
|
+
|
|
251
|
+
|
|
252
|
+
|
|
253
|
+
With rngList
|
|
254
|
+
|
|
255
|
+
Set rngList = .Cells(.Rows.Count, 2).Resize(UBound(vrtNewList, 1), UBound(vrtNewList, 2))
|
|
256
|
+
|
|
257
|
+
End With
|
|
258
|
+
|
|
259
|
+
rngList.Value = vrtNewList
|
|
260
|
+
|
|
261
|
+
|
|
262
|
+
|
|
263
|
+
End Sub
|
|
264
|
+
|
|
265
|
+
|
|
266
|
+
|
|
267
|
+
|
|
268
|
+
|
|
269
|
+
|
|
164
270
|
|
|
165
271
|
|
|
166
272
|
|
2
ソースコードを追加
test
CHANGED
|
File without changes
|
test
CHANGED
|
@@ -51,6 +51,42 @@
|
|
|
51
51
|
|
|
52
52
|
|
|
53
53
|
（これより前にもソースコードの記載はありますが、割愛します）
|
|
54
|
+
|
|
55
|
+
|
|
56
|
+
|
|
57
|
+
'一覧のAQ列が空欄の行をクリア
|
|
58
|
+
|
|
59
|
+
Private Sub InitializeTable(ByRef rngList As Range)
|
|
60
|
+
|
|
61
|
+
Dim rngBlank As Range
|
|
62
|
+
|
|
63
|
+
|
|
64
|
+
|
|
65
|
+
With rngList
|
|
66
|
+
|
|
67
|
+
If rngList.Rows.Count > 1 Then
|
|
68
|
+
|
|
69
|
+
On Error Resume Next
|
|
70
|
+
|
|
71
|
+
Set rngBlank = rngList.Columns(43).SpecialCells(xlCellTypeBlanks)
|
|
72
|
+
|
|
73
|
+
On Error GoTo 0
|
|
74
|
+
|
|
75
|
+
If rngBlank Is Nothing Then Exit Sub
|
|
76
|
+
|
|
77
|
+
|
|
78
|
+
|
|
79
|
+
rngBlank.EntireRow.ClearContents
|
|
80
|
+
|
|
81
|
+
rngList.Sort Key1:=rngList(4), Order1:=xlAscending, Header:=xlYes
|
|
82
|
+
|
|
83
|
+
End If
|
|
84
|
+
|
|
85
|
+
Set rngList = rngList.CurrentRegion
|
|
86
|
+
|
|
87
|
+
End With
|
|
88
|
+
|
|
89
|
+
End Sub
|
|
54
90
|
|
|
55
91
|
|
|
56
92
|
|
1
誤字脱字の修正
test
CHANGED
|
File without changes
|
test
CHANGED
|
File without changes
|