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

編集履歴

回答編集履歴

4

コメント行の挿入位置を間違えました。

2020/08/21 02:38

投稿

kitasue
kitasue

スコア314

test CHANGED
@@ -3,10 +3,6 @@
3
3
  を参照設定して、連想配列を使ってやってみました。
4
4
 
5
5
  ```VBA
6
-
7
- Option Explicit
8
-
9
-
10
6
 
11
7
  Sub KosuBook()
12
8
 
@@ -78,11 +74,11 @@
78
74
 
79
75
  dctRowKomoku.Add wshKousu.Cells(lngRow, cnsColKousuKomoku).Value, lngRow
80
76
 
81
- lngRow = wshKousu.Cells(lngRow, cnsColKousuKomoku).End(xlDown).Row
82
-
83
77
  '2020/08/21 11:26 upd start
84
78
 
85
79
  ' Next lngRow
80
+
81
+ lngRow = wshKousu.Cells(lngRow, cnsColKousuKomoku).End(xlDown).Row
86
82
 
87
83
  Loop
88
84
 
@@ -146,8 +142,6 @@
146
142
 
147
143
  End Sub
148
144
 
149
-
150
-
151
145
  ```
152
146
 
153
147
  私の手元ではうまく行ってます。

3

ループの仕方を変更

2020/08/21 02:38

投稿

kitasue
kitasue

スコア314

test CHANGED
@@ -3,6 +3,10 @@
3
3
  を参照設定して、連想配列を使ってやってみました。
4
4
 
5
5
  ```VBA
6
+
7
+ Option Explicit
8
+
9
+
6
10
 
7
11
  Sub KosuBook()
8
12
 
@@ -20,7 +24,7 @@
20
24
 
21
25
  Const cnsColYoteiBgn = 10
22
26
 
23
-
27
+
24
28
 
25
29
  Dim wbkYotei As Workbook
26
30
 
@@ -50,7 +54,7 @@
50
54
 
51
55
  Dim dctColHizuke As Dictionary
52
56
 
53
-
57
+
54
58
 
55
59
  Set dctRowKomoku = New Dictionary
56
60
 
@@ -58,17 +62,31 @@
58
62
 
59
63
  Set wshKousu = ThisWorkbook.Worksheets(1)
60
64
 
61
-
65
+
62
66
 
63
67
  lngRowKousuEnd = wshKousu.Cells(Rows.Count, cnsColKousuKomoku).End(xlUp).Row
64
68
 
69
+ '2020/08/21 11:26 upd start
70
+
65
- For lngRow = cnsRowKousuBgn To lngRowKousuEnd Step 10
71
+ ' For lngRow = cnsRowKousuBgn To lngRowKousuEnd Step 10
72
+
73
+ lngRow = cnsRowKousuBgn
74
+
75
+ Do Until lngRow > lngRowKousuEnd
76
+
77
+ '2020/08/21 11:26 upd end
66
78
 
67
79
  dctRowKomoku.Add wshKousu.Cells(lngRow, cnsColKousuKomoku).Value, lngRow
68
80
 
69
- Next lngRow
81
+ lngRow = wshKousu.Cells(lngRow, cnsColKousuKomoku).End(xlDown).Row
70
82
 
71
-
83
+ '2020/08/21 11:26 upd start
84
+
85
+ ' Next lngRow
86
+
87
+ Loop
88
+
89
+ '2020/08/21 11:26 upd end
72
90
 
73
91
  lngColKousuEnd = wshKousu.Cells(cnsRowKousuHizuke, Columns.Count).End(xlToLeft).Column
74
92
 
@@ -78,7 +96,7 @@
78
96
 
79
97
  Next lngCol
80
98
 
81
-
99
+
82
100
 
83
101
  strPath = "〇〇〇.xlsm"
84
102
 
@@ -114,7 +132,7 @@
114
132
 
115
133
  Next lngWshNum
116
134
 
117
-
135
+
118
136
 
119
137
  wbkYotei.Close SaveChanges:=False: Set wbkYotei = Nothing
120
138
 
@@ -124,9 +142,11 @@
124
142
 
125
143
  Set dctRowKomoku = Nothing
126
144
 
127
-
145
+
128
146
 
129
147
  End Sub
148
+
149
+
130
150
 
131
151
  ```
132
152
 

2

複数ワークシートに対応

2020/08/21 02:29

投稿

kitasue
kitasue

スコア314

test CHANGED
@@ -6,25 +6,23 @@
6
6
 
7
7
  Sub KosuBook()
8
8
 
9
- Const lngRowKousuHizuke = 2
9
+ Const cnsRowKousuHizuke = 2
10
10
 
11
- Const lngRowKousuBgn = 3
11
+ Const cnsRowKousuBgn = 3
12
12
 
13
- Const lngColKousuKomoku = 4
13
+ Const cnsColKousuKomoku = 4
14
14
 
15
- Const lngColKousuBgn = 13
15
+ Const cnsColKousuBgn = 13
16
16
 
17
- Const lngColYoteiBgn = 10
17
+ Const cnsRowYoteiHizuke = 1
18
18
 
19
- Const lngRowYoteiBgn = 3
19
+ Const cnsRowYoteiBgn = 3
20
20
 
21
- Const lngRowYoteiHizuke = 1
21
+ Const cnsColYoteiBgn = 10
22
22
 
23
23
 
24
24
 
25
25
  Dim wbkYotei As Workbook
26
-
27
- Dim wshYotei As Worksheet
28
26
 
29
27
  Dim wshKousu As Worksheet
30
28
 
@@ -46,11 +44,13 @@
46
44
 
47
45
  Dim lngCol As Long
48
46
 
47
+ Dim lngWshNum As Long
48
+
49
49
  Dim dctRowKomoku As Dictionary
50
50
 
51
51
  Dim dctColHizuke As Dictionary
52
52
 
53
-
53
+
54
54
 
55
55
  Set dctRowKomoku = New Dictionary
56
56
 
@@ -60,21 +60,21 @@
60
60
 
61
61
 
62
62
 
63
- lngRowKousuEnd = Cells(Rows.Count, lngColKousuKomoku).End(xlUp).Row
63
+ lngRowKousuEnd = wshKousu.Cells(Rows.Count, cnsColKousuKomoku).End(xlUp).Row
64
64
 
65
- For lngRow = lngRowKousuBgn To lngRowKousuEnd Step 10
65
+ For lngRow = cnsRowKousuBgn To lngRowKousuEnd Step 10
66
66
 
67
- dctRowKomoku.Add wshKousu.Cells(lngRow, lngColKousuKomoku).Value, lngRow
67
+ dctRowKomoku.Add wshKousu.Cells(lngRow, cnsColKousuKomoku).Value, lngRow
68
68
 
69
69
  Next lngRow
70
70
 
71
71
 
72
72
 
73
- lngColKousuEnd = Cells(lngRowKousuHizuke, Columns.Count).End(xlToLeft).Column
73
+ lngColKousuEnd = wshKousu.Cells(cnsRowKousuHizuke, Columns.Count).End(xlToLeft).Column
74
74
 
75
- For lngCol = lngColKousuBgn To lngColKousuEnd
75
+ For lngCol = cnsColKousuBgn To lngColKousuEnd
76
76
 
77
- dctColHizuke.Add wshKousu.Cells(lngRowKousuHizuke, lngCol).Value, lngCol
77
+ dctColHizuke.Add wshKousu.Cells(cnsRowKousuHizuke, lngCol).Value, lngCol
78
78
 
79
79
  Next lngCol
80
80
 
@@ -84,39 +84,41 @@
84
84
 
85
85
  Set wbkYotei = Workbooks.Open(strPath)
86
86
 
87
- Set wshYotei = wbkYotei.Worksheets(1)
87
+ For lngWshNum = 1 To wbkYotei.Worksheets.Count
88
+
89
+ With wbkYotei.Worksheets(lngWshNum)
90
+
91
+ lngColYoteiEnd = cnsColYoteiBgn + 12
92
+
93
+ For lngCol = cnsColYoteiBgn To lngColYoteiEnd Step 2
94
+
95
+ lngRowYoteiEnd = .Cells(Rows.Count, lngCol).End(xlUp).Row
96
+
97
+ For lngRow = cnsRowYoteiBgn To lngRowYoteiEnd
98
+
99
+ lngRowKousu = dctRowKomoku.Item(.Cells(lngRow, lngCol).Value)
100
+
101
+ lngColKousu = dctColHizuke.Item(.Cells(cnsRowYoteiHizuke, lngCol - 1).Value)
102
+
103
+ If lngRowKousu > 0 And lngColKousu > 0 Then
104
+
105
+ wshKousu.Cells(lngRowKousu, lngColKousu).Value = wshKousu.Cells(lngRowKousu, lngColKousu).Value + 0.5
106
+
107
+ End If
108
+
109
+ Next lngRow
110
+
111
+ Next lngCol
112
+
113
+ End With
114
+
115
+ Next lngWshNum
88
116
 
89
117
 
90
118
 
91
- lngColYoteiEnd = lngColYoteiBgn + 12
92
-
93
- For lngCol = lngColYoteiBgn To lngColYoteiEnd Step 2
119
+ wbkYotei.Close SaveChanges:=False: Set wbkYotei = Nothing
94
-
95
- lngRowYoteiEnd = Cells(Rows.Count, lngCol).End(xlUp).Row
96
-
97
- For lngRow = lngRowYoteiBgn To lngRowYoteiEnd
98
-
99
- lngRowKousu = dctRowKomoku.Item(wshYotei.Cells(lngRow, lngCol).Value)
100
-
101
- lngColKousu = dctColHizuke.Item(wshYotei.Cells(lngRowYoteiHizuke, lngCol - 1).Value)
102
-
103
- If lngRowKousu > 0 And lngColKousu > 0 Then
104
-
105
- wshKousu.Cells(lngRowKousu, lngColKousu).Value = wshKousu.Cells(lngRowKousu, lngColKousu).Value + 0.5
106
-
107
- End If
108
-
109
- Next lngRow
110
-
111
- Next lngCol
112
-
113
-
114
120
 
115
121
  Set wshKousu = Nothing
116
-
117
- Set wshYotei = Nothing
118
-
119
- wbkYotei.Close SaveChanges:=False: Set wbkYotei = Nothing
120
122
 
121
123
  Set dctColHizuke = Nothing
122
124
 
@@ -128,4 +130,4 @@
128
130
 
129
131
  ```
130
132
 
131
- ワークシートのループのところはサボりました。ごめんなさい。
133
+ 私の手元ではうまく行ってます。

1

追記

2020/08/20 05:02

投稿

kitasue
kitasue

スコア314

test CHANGED
@@ -127,3 +127,5 @@
127
127
  End Sub
128
128
 
129
129
  ```
130
+
131
+ ワークシートのループのところはサボりました。ごめんなさい。