回答編集履歴
4
コメント行の挿入位置を間違えました。
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
ループの仕方を変更
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
複数ワークシートに対応
answer
CHANGED
@@ -2,16 +2,15 @@
|
|
2
2
|
を参照設定して、連想配列を使ってやってみました。
|
3
3
|
```VBA
|
4
4
|
Sub KosuBook()
|
5
|
-
Const
|
5
|
+
Const cnsRowKousuHizuke = 2
|
6
|
-
Const
|
6
|
+
Const cnsRowKousuBgn = 3
|
7
|
-
Const
|
7
|
+
Const cnsColKousuKomoku = 4
|
8
|
-
Const
|
8
|
+
Const cnsColKousuBgn = 13
|
9
|
-
Const lngColYoteiBgn = 10
|
10
|
-
Const lngRowYoteiBgn = 3
|
11
|
-
Const
|
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,
|
32
|
+
lngRowKousuEnd = wshKousu.Cells(Rows.Count, cnsColKousuKomoku).End(xlUp).Row
|
33
|
-
For lngRow =
|
33
|
+
For lngRow = cnsRowKousuBgn To lngRowKousuEnd Step 10
|
34
|
-
dctRowKomoku.Add wshKousu.Cells(lngRow,
|
34
|
+
dctRowKomoku.Add wshKousu.Cells(lngRow, cnsColKousuKomoku).Value, lngRow
|
35
35
|
Next lngRow
|
36
36
|
|
37
|
-
lngColKousuEnd = Cells(
|
37
|
+
lngColKousuEnd = wshKousu.Cells(cnsRowKousuHizuke, Columns.Count).End(xlToLeft).Column
|
38
|
-
For lngCol =
|
38
|
+
For lngCol = cnsColKousuBgn To lngColKousuEnd
|
39
|
-
dctColHizuke.Add wshKousu.Cells(
|
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
|
-
|
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
|
-
|
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
追記
answer
CHANGED
@@ -62,4 +62,5 @@
|
|
62
62
|
Set dctRowKomoku = Nothing
|
63
63
|
|
64
64
|
End Sub
|
65
|
-
```
|
65
|
+
```
|
66
|
+
ワークシートのループのところはサボりました。ごめんなさい。
|