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

編集履歴

回答編集履歴

4

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

2020/08/21 02:38

投稿

kitasue
kitasue

スコア314

answer CHANGED
@@ -1,8 +1,6 @@
1
1
  Microsoft Scripting Runtime
2
2
  を参照設定して、連想配列を使ってやってみました。
3
3
  ```VBA
4
- Option Explicit
5
-
6
4
  Sub KosuBook()
7
5
  Const cnsRowKousuHizuke = 2
8
6
  Const cnsRowKousuBgn = 3
@@ -38,9 +36,9 @@
38
36
  Do Until lngRow > lngRowKousuEnd
39
37
  '2020/08/21 11:26 upd end
40
38
  dctRowKomoku.Add wshKousu.Cells(lngRow, cnsColKousuKomoku).Value, lngRow
41
- lngRow = wshKousu.Cells(lngRow, cnsColKousuKomoku).End(xlDown).Row
42
39
  '2020/08/21 11:26 upd start
43
40
  ' Next lngRow
41
+ lngRow = wshKousu.Cells(lngRow, cnsColKousuKomoku).End(xlDown).Row
44
42
  Loop
45
43
  '2020/08/21 11:26 upd end
46
44
  lngColKousuEnd = wshKousu.Cells(cnsRowKousuHizuke, Columns.Count).End(xlToLeft).Column
@@ -72,6 +70,5 @@
72
70
  Set dctRowKomoku = Nothing
73
71
 
74
72
  End Sub
75
-
76
73
  ```
77
74
  私の手元ではうまく行ってます。

3

ループの仕方を変更

2020/08/21 02:38

投稿

kitasue
kitasue

スコア314

answer CHANGED
@@ -1,6 +1,8 @@
1
1
  Microsoft Scripting Runtime
2
2
  を参照設定して、連想配列を使ってやってみました。
3
3
  ```VBA
4
+ Option Explicit
5
+
4
6
  Sub KosuBook()
5
7
  Const cnsRowKousuHizuke = 2
6
8
  Const cnsRowKousuBgn = 3
@@ -9,7 +11,7 @@
9
11
  Const cnsRowYoteiHizuke = 1
10
12
  Const cnsRowYoteiBgn = 3
11
13
  Const cnsColYoteiBgn = 10
12
-
14
+
13
15
  Dim wbkYotei As Workbook
14
16
  Dim wshKousu As Worksheet
15
17
  Dim strPath As String
@@ -24,21 +26,28 @@
24
26
  Dim lngWshNum As Long
25
27
  Dim dctRowKomoku As Dictionary
26
28
  Dim dctColHizuke As Dictionary
27
-
29
+
28
30
  Set dctRowKomoku = New Dictionary
29
31
  Set dctColHizuke = New Dictionary
30
32
  Set wshKousu = ThisWorkbook.Worksheets(1)
31
-
33
+
32
34
  lngRowKousuEnd = wshKousu.Cells(Rows.Count, cnsColKousuKomoku).End(xlUp).Row
35
+ '2020/08/21 11:26 upd start
33
- For lngRow = cnsRowKousuBgn To lngRowKousuEnd Step 10
36
+ ' For lngRow = cnsRowKousuBgn To lngRowKousuEnd Step 10
37
+ lngRow = cnsRowKousuBgn
38
+ Do Until lngRow > lngRowKousuEnd
39
+ '2020/08/21 11:26 upd end
34
40
  dctRowKomoku.Add wshKousu.Cells(lngRow, cnsColKousuKomoku).Value, lngRow
41
+ lngRow = wshKousu.Cells(lngRow, cnsColKousuKomoku).End(xlDown).Row
42
+ '2020/08/21 11:26 upd start
35
- Next lngRow
43
+ ' Next lngRow
36
-
44
+ Loop
45
+ '2020/08/21 11:26 upd end
37
46
  lngColKousuEnd = wshKousu.Cells(cnsRowKousuHizuke, Columns.Count).End(xlToLeft).Column
38
47
  For lngCol = cnsColKousuBgn To lngColKousuEnd
39
48
  dctColHizuke.Add wshKousu.Cells(cnsRowKousuHizuke, lngCol).Value, lngCol
40
49
  Next lngCol
41
-
50
+
42
51
  strPath = "〇〇〇.xlsm"
43
52
  Set wbkYotei = Workbooks.Open(strPath)
44
53
  For lngWshNum = 1 To wbkYotei.Worksheets.Count
@@ -56,12 +65,13 @@
56
65
  Next lngCol
57
66
  End With
58
67
  Next lngWshNum
59
-
68
+
60
69
  wbkYotei.Close SaveChanges:=False: Set wbkYotei = Nothing
61
70
  Set wshKousu = Nothing
62
71
  Set dctColHizuke = Nothing
63
72
  Set dctRowKomoku = Nothing
64
-
73
+
65
74
  End Sub
75
+
66
76
  ```
67
77
  私の手元ではうまく行ってます。

2

複数ワークシートに対応

2020/08/21 02:29

投稿

kitasue
kitasue

スコア314

answer CHANGED
@@ -2,16 +2,15 @@
2
2
  を参照設定して、連想配列を使ってやってみました。
3
3
  ```VBA
4
4
  Sub KosuBook()
5
- Const lngRowKousuHizuke = 2
5
+ Const cnsRowKousuHizuke = 2
6
- Const lngRowKousuBgn = 3
6
+ Const cnsRowKousuBgn = 3
7
- Const lngColKousuKomoku = 4
7
+ Const cnsColKousuKomoku = 4
8
- Const lngColKousuBgn = 13
8
+ Const cnsColKousuBgn = 13
9
- Const lngColYoteiBgn = 10
10
- Const lngRowYoteiBgn = 3
11
- Const lngRowYoteiHizuke = 1
9
+ Const cnsRowYoteiHizuke = 1
10
+ Const cnsRowYoteiBgn = 3
11
+ Const cnsColYoteiBgn = 10
12
12
 
13
13
  Dim wbkYotei As Workbook
14
- Dim wshYotei As Worksheet
15
14
  Dim wshKousu As Worksheet
16
15
  Dim strPath As String
17
16
  Dim lngRowKousuEnd As Long
@@ -22,45 +21,47 @@
22
21
  Dim lngColYoteiEnd As Long
23
22
  Dim lngRow As Long
24
23
  Dim lngCol As Long
24
+ Dim lngWshNum As Long
25
25
  Dim dctRowKomoku As Dictionary
26
26
  Dim dctColHizuke As Dictionary
27
-
27
+
28
28
  Set dctRowKomoku = New Dictionary
29
29
  Set dctColHizuke = New Dictionary
30
30
  Set wshKousu = ThisWorkbook.Worksheets(1)
31
31
 
32
- lngRowKousuEnd = Cells(Rows.Count, lngColKousuKomoku).End(xlUp).Row
32
+ lngRowKousuEnd = wshKousu.Cells(Rows.Count, cnsColKousuKomoku).End(xlUp).Row
33
- For lngRow = lngRowKousuBgn To lngRowKousuEnd Step 10
33
+ For lngRow = cnsRowKousuBgn To lngRowKousuEnd Step 10
34
- dctRowKomoku.Add wshKousu.Cells(lngRow, lngColKousuKomoku).Value, lngRow
34
+ dctRowKomoku.Add wshKousu.Cells(lngRow, cnsColKousuKomoku).Value, lngRow
35
35
  Next lngRow
36
36
 
37
- lngColKousuEnd = Cells(lngRowKousuHizuke, Columns.Count).End(xlToLeft).Column
37
+ lngColKousuEnd = wshKousu.Cells(cnsRowKousuHizuke, Columns.Count).End(xlToLeft).Column
38
- For lngCol = lngColKousuBgn To lngColKousuEnd
38
+ For lngCol = cnsColKousuBgn To lngColKousuEnd
39
- dctColHizuke.Add wshKousu.Cells(lngRowKousuHizuke, lngCol).Value, lngCol
39
+ dctColHizuke.Add wshKousu.Cells(cnsRowKousuHizuke, lngCol).Value, lngCol
40
40
  Next lngCol
41
41
 
42
42
  strPath = "〇〇〇.xlsm"
43
43
  Set wbkYotei = Workbooks.Open(strPath)
44
- Set wshYotei = wbkYotei.Worksheets(1)
44
+ For lngWshNum = 1 To wbkYotei.Worksheets.Count
45
+ With wbkYotei.Worksheets(lngWshNum)
46
+ lngColYoteiEnd = cnsColYoteiBgn + 12
47
+ For lngCol = cnsColYoteiBgn To lngColYoteiEnd Step 2
48
+ lngRowYoteiEnd = .Cells(Rows.Count, lngCol).End(xlUp).Row
49
+ For lngRow = cnsRowYoteiBgn To lngRowYoteiEnd
50
+ lngRowKousu = dctRowKomoku.Item(.Cells(lngRow, lngCol).Value)
51
+ lngColKousu = dctColHizuke.Item(.Cells(cnsRowYoteiHizuke, lngCol - 1).Value)
52
+ If lngRowKousu > 0 And lngColKousu > 0 Then
53
+ wshKousu.Cells(lngRowKousu, lngColKousu).Value = wshKousu.Cells(lngRowKousu, lngColKousu).Value + 0.5
54
+ End If
55
+ Next lngRow
56
+ Next lngCol
57
+ End With
58
+ Next lngWshNum
45
59
 
46
- lngColYoteiEnd = lngColYoteiBgn + 12
47
- For lngCol = lngColYoteiBgn To lngColYoteiEnd Step 2
60
+ wbkYotei.Close SaveChanges:=False: Set wbkYotei = Nothing
48
- lngRowYoteiEnd = Cells(Rows.Count, lngCol).End(xlUp).Row
49
- For lngRow = lngRowYoteiBgn To lngRowYoteiEnd
50
- lngRowKousu = dctRowKomoku.Item(wshYotei.Cells(lngRow, lngCol).Value)
51
- lngColKousu = dctColHizuke.Item(wshYotei.Cells(lngRowYoteiHizuke, lngCol - 1).Value)
52
- If lngRowKousu > 0 And lngColKousu > 0 Then
53
- wshKousu.Cells(lngRowKousu, lngColKousu).Value = wshKousu.Cells(lngRowKousu, lngColKousu).Value + 0.5
54
- End If
55
- Next lngRow
56
- Next lngCol
57
-
58
61
  Set wshKousu = Nothing
59
- Set wshYotei = Nothing
60
- wbkYotei.Close SaveChanges:=False: Set wbkYotei = Nothing
61
62
  Set dctColHizuke = Nothing
62
63
  Set dctRowKomoku = Nothing
63
64
 
64
65
  End Sub
65
66
  ```
66
- ワークシートのループのところはサボりました。ごめんなさい。
67
+ 私の手元ではうまく行ってます。

1

追記

2020/08/20 05:02

投稿

kitasue
kitasue

スコア314

answer CHANGED
@@ -62,4 +62,5 @@
62
62
  Set dctRowKomoku = Nothing
63
63
 
64
64
  End Sub
65
- ```
65
+ ```
66
+ ワークシートのループのところはサボりました。ごめんなさい。