teratail
回答率
85.48%
質問するログイン新規登録
トップに関する質問VBA　他のブックから名前を参照して、名前の数分、値を同じ名前と日付のセルに入れたい

編集履歴

質問編集履歴

8

変更

2020/08/05 01:26

投稿

beginner101
beginner101

スコア18

test CHANGED
File without changes
test CHANGED
@@ -38,7 +38,7 @@
38
38
 
39
39
 
40
40
 
41
- 予定表　一週間ごとに別のシート　ここの作業名の数を合計して0.5掛ける
41
+ 予定表　一週間ごとに別のシート　ここの作業名の数を合計して0.5掛ける　その他は無視する
42
42
 
43
43
 
44
44
 

7

変更

2020/08/05 01:26

投稿

beginner101
beginner101

スコア18

test CHANGED
@@ -1 +1 @@
1
- 他のブックから名前を参照して、名前の数分、値を同じ名前と日付のセルに入れたい
1
+ VBA　他のブックから名前を参照して、名前の数分、値を同じ名前と日付のセルに入れたい
test CHANGED
File without changes

6

変更

2020/08/04 09:20

投稿

beginner101
beginner101

スコア18

test CHANGED
File without changes
test CHANGED
@@ -74,7 +74,7 @@
74
74
 
75
75
  ```ここに言語名を入力
76
76
 
77
- Sub ReferOtherBook()
77
+ Sub KosuBook()
78
78
 
79
79
  Dim ex As Excel.Application '処理用Excel
80
80
 

5

変更

2020/08/04 08:39

投稿

beginner101
beginner101

スコア18

test CHANGED
File without changes
test CHANGED
@@ -60,7 +60,9 @@
60
60
 
61
61
 
62
62
 
63
- 工数がM4セルから入力される
63
+ 工数がM4セルから入力される。
64
+
65
+ 集計し終わったら、下の項目に移動して、項目がなくなるまで続ける
64
66
 
65
67
 
66
68
 

4

変更点

2020/08/04 04:12

投稿

beginner101
beginner101

スコア18

test CHANGED
File without changes
test CHANGED
@@ -38,19 +38,29 @@
38
38
 
39
39
 
40
40
 
41
+ 予定表　一週間ごとに別のシート　ここの作業名の数を合計して0.5掛ける
42
+
43
+
44
+
45
+ ![イメージ説明](9538d9f8874d86a802302468542881da.png)
46
+
47
+
48
+
41
49
  工数表　項目は複数存在
42
50
 
51
+ ![イメージ説明](6617c70959fe851eae81d170ef42f1e4.png)
52
+
53
+
54
+
55
+ ↓マクロ起動後
56
+
57
+
58
+
43
59
  ![イメージ説明](9b4dc3a7bfe531aee0dd5e2fc25a3767.png)
44
60
 
45
61
 
46
62
 
47
- 予定表　一週間ごとに別のシート
63
+ 工数がM4セルから入力される
48
-
49
-
50
-
51
- ![イメージ説明](9538d9f8874d86a802302468542881da.png)
52
-
53
-
54
64
 
55
65
 
56
66
 

3

変更

2020/08/04 04:10

投稿

beginner101
beginner101

スコア18

test CHANGED
File without changes
test CHANGED
@@ -12,9 +12,35 @@
12
12
 
13
13
 
14
14
 
15
+ 手順
16
+
17
+ 転記元ファイルのシート1のEからRまでの範囲を一列ごとに指定
18
+
19
+ 空なら翌日に移動
20
+
21
+ 列の単語ごとに何個ずつあるか計算し、0.5を掛ける
22
+
23
+ 出した値を列の日付と項目の名前が同じところにあるセルに入力
24
+
25
+ その列で単語がなくなるまで繰り返す
26
+
27
+ 単語がなくなったら翌日の実績列に移動
28
+
29
+ 日曜日まで終わったら隣のシートに移動
30
+
31
+ シートがなくなるまで繰り返す
32
+
33
+
34
+
35
+ 転記元のシート名は毎回異なる
36
+
37
+ 転記元の日付は日付が入っているセルの左に書いてある
38
+
39
+
40
+
15
41
  工数表　項目は複数存在
16
42
 
17
- ![イメージ説明](6a74a9dfb1d22ec31b5ca94cd847b1b8.png)
43
+ ![イメージ説明](9b4dc3a7bfe531aee0dd5e2fc25a3767.png)
18
44
 
19
45
 
20
46
 
@@ -22,7 +48,7 @@
22
48
 
23
49
 
24
50
 
25
- ![イメージ説明](3ccc30f967378f3bce4e99c7cb1858d3.png)
51
+ ![イメージ説明](9538d9f8874d86a802302468542881da.png)
26
52
 
27
53
 
28
54
 

2

変更点2

2020/08/04 00:13

投稿

beginner101
beginner101

スコア18

test CHANGED
File without changes
test CHANGED
@@ -38,43 +38,51 @@
38
38
 
39
39
  Sub ReferOtherBook()
40
40
 
41
- Dim ex As Excel.Application '// 処理用Excel
41
+ Dim ex As Excel.Application '処理用Excel
42
42
 
43
43
  Dim wb As Workbook
44
44
 
45
- Dim sPath '// ブックファイルパス
45
+ Dim sPath 'ブックファイルパス
46
-
46
+
47
- Dim sht As Worksheet '// 参照シート
47
+ Dim sht As Worksheet '参照シート
48
48
 
49
49
  Dim bFlg As Boolean
50
50
 
51
+ Dim kRow As Long
52
+
53
+ Dim cnt As Long
54
+
55
+ Dim i, j, k, kosu As Long
56
+
57
+
58
+
51
59
 
52
60
 
53
61
  '開くブックを指定
54
62
 
55
- sPath = "https://jssnet-my.sharepoint.com/personal/takeshita_naoyuki_jss-net_com/Documents/takeshita/D/20200718_%E9%80%B2%E6%8D%97%E7%AE%A1%E7%90%86%E3%82%B7%E3%83%BC%E3%83%88/2020_07(%E7%AB%B9%E4%B8%8B).xlsm"
56
-
57
-
58
-
59
- '// 既に開かれているか確認
63
+ sPath = "〇〇〇.xlsm"
64
+
65
+
66
+
67
+ '既に開かれているか確認
60
68
 
61
69
  bFlg = IsBookOpened(sPath)
62
70
 
63
71
 
64
72
 
65
- '// 開かれている場合
73
+ '開かれている場合
66
74
 
67
75
  If bFlg = True Then
68
76
 
69
77
  Set ex = New Excel.Application
70
78
 
71
- '// 新規Excelで読み取り専用で開く
79
+ '新規Excelで読み取り専用で開く
72
80
 
73
81
  Set wb = ex.Workbooks.Open(Filename:=sPath, UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
74
82
 
75
83
  Else
76
84
 
77
- '// 現ブックで読み取り専用で開く
85
+ '現ブックで読み取り専用で開く
78
86
 
79
87
  Set wb = Workbooks.Open(Filename:=sPath, UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
80
88
 
@@ -82,82 +90,112 @@
82
90
 
83
91
 
84
92
 
85
- '工数を集計後、同じ工数にあたる小項目を探し、合計を入力する
93
+ '工数を集計後、同じ工数にあたる項目を探し、合計を入力する
94
+
86
-
95
+ '1yori
96
+
87
- 'シートの数だけ繰り返し
97
+ '1と後の数字名シートの数だけ繰り返し
88
-
89
- '詳細スケジュールの項目の日付のセルに作業数合計値×0.5を入力
98
+
90
-
91
- For i = 1 To tbook.Sheets.Count
99
+ For i = 1 To Worksheets.Count
100
+
92
-
101
+ '列ごとに繰り返し
102
+
93
-
103
+ For j = 6 To 18 Step 2
104
+
94
-
105
+ '最後のセルまで取得
106
+
95
- mRow = ws02.Cells(Rows.Count, "C").End(xlUp).Row
107
+ kRow = Cells(Rows.Count, j).End(xlUp).Row
108
+
96
-
109
+ '調べる作業名（重複は除く）
110
+
111
+
112
+
113
+ k = 0
114
+
115
+ Do
116
+
117
+ n = InStr(k + 1, kRow, '作業名)
118
+
119
+ If k = 0 Then
120
+
121
+ Exit Do
122
+
123
+ Else
124
+
125
+ cnt = cnt + 1
126
+
127
+ End If
128
+
129
+ Loop
130
+
131
+ kousu = cnt * 0.5
132
+
97
- '条件に一致したシート名を対象に処理
133
+ '工数表のブックへ内容をコピー
134
+
135
+
136
+
98
-
137
+ Next j
138
+
139
+ Next　i
140
+
141
+
142
+
143
+
144
+
145
+ 'ブックを閉じる
146
+
147
+ Call wb.Close
148
+
149
+
150
+
99
- If tbook.Sheets(i).Name Like "売上*" Then
151
+ If bFlg = True Then
100
-
152
+
101
- '対象のシートのセルA10より値を取得し、変数cntに加算
153
+ Call ex.Application.Quit
102
-
103
- cnt = cnt + tbook.Sheets(i).Range("A10").Value
104
154
 
105
155
  End If
106
156
 
157
+
158
+
159
+
160
+
107
- Next i
161
+ End Sub
162
+
163
+
164
+
108
-
165
+ 'ブックオープン判定関数
166
+
109
-
167
+ Function IsBookOpened(a_sFilePath) As Boolean
168
+
110
-
169
+ On Error Resume Next
170
+
171
+
172
+
111
- '// ブックを閉じる
173
+ '保存済みのブックか判定
174
+
112
-
175
+ Open a_sFilePath For Append As #1
176
+
113
- Call wb.Close
177
+ Close #1
114
-
115
-
116
-
178
+
179
+
180
+
117
- If bFlg = True Then
181
+ If Err.Number > 0 Then
182
+
118
-
183
+ '既に開かれている場合
184
+
119
- Call ex.Application.Quit
185
+ IsBookOpened = True
186
+
187
+ Else
188
+
189
+ '開かれていない場合
190
+
191
+ IsBookOpened = False
120
192
 
121
193
  End If
122
194
 
123
-
124
-
125
- End Sub
126
-
127
-
128
-
129
- 'ブックオープン判定関数
130
-
131
- Function IsBookOpened(a_sFilePath) As Boolean
132
-
133
- On Error Resume Next
134
-
135
-
136
-
137
- '// 保存済みのブックか判定
138
-
139
- Open a_sFilePath For Append As #1
140
-
141
- Close #1
142
-
143
-
144
-
145
- If Err.Number > 0 Then
146
-
147
- '// 既に開かれている場合
148
-
149
- IsBookOpened = True
150
-
151
- Else
152
-
153
- '// 開かれていない場合
154
-
155
- IsBookOpened = False
156
-
157
- End If
158
-
159
195
  End Function
160
196
 
197
+
198
+
161
199
  ```
162
200
 
163
201
 

1

変更点

2020/08/03 07:45

投稿

beginner101
beginner101

スコア18

test CHANGED
File without changes
test CHANGED
@@ -19,6 +19,10 @@
19
19
 
20
20
 
21
21
  予定表　一週間ごとに別のシート
22
+
23
+
24
+
25
+ ![イメージ説明](3ccc30f967378f3bce4e99c7cb1858d3.png)
22
26
 
23
27
 
24
28