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

編集履歴

回答編集履歴

8

個人的な情報が入ったままでしたので、削除しただけです。コードに変更はありません。

2020/08/22 08:32

投稿

kitasue
kitasue

スコア314

answer CHANGED
@@ -27,7 +27,7 @@
27
27
  Set dctRowKomoku = New Dictionary
28
28
  Set dctColHizuke = New Dictionary
29
29
 
30
- strPath = "C:\Users\kitasue\Documents\工数表は５シート目.xlsm"
30
+ strPath = "工数表は５シート目.xlsm"
31
31
  Set wbkKousu = Workbooks.Open(strPath)
32
32
  Set wshKousu = wbkKousu.Worksheets(5)
33
33
 

7

スペルミスの修正

2020/08/22 08:32

投稿

kitasue
kitasue

スコア314

answer CHANGED
@@ -48,7 +48,7 @@
48
48
  dctColHizuke.Add wshKousu.Cells(cnsRowKousuHizuke, lngCol).Value, lngCol
49
49
  Next lngCol
50
50
  '2020/08/21 15:25 add start
51
- wshKousu.Range(wshKousu.Cells(cnsRowKousuBgn, cnsColKousuBgn), wshKousu.Cells(lngRowKousuEnd, lngColKousuEnd)).ClearComments
51
+ wshKousu.Range(wshKousu.Cells(cnsRowKousuBgn, cnsColKousuBgn), wshKousu.Cells(lngRowKousuEnd, lngColKousuEnd)).ClearContents
52
52
  '2020/08/21 15:25 add end
53
53
  For lngWshNum = 1 To ThisWorkbook.Worksheets.Count
54
54
  With ThisWorkbook.Worksheets(lngWshNum)

6

空白項目のチェックを追加

2020/08/21 07:41

投稿

kitasue
kitasue

スコア314

answer CHANGED
@@ -27,7 +27,7 @@
27
27
  Set dctRowKomoku = New Dictionary
28
28
  Set dctColHizuke = New Dictionary
29
29
 
30
- strPath = "工数表は５シート目.xlsm"
30
+ strPath = "C:\Users\kitasue\Documents\工数表は５シート目.xlsm"
31
31
  Set wbkKousu = Workbooks.Open(strPath)
32
32
  Set wshKousu = wbkKousu.Worksheets(5)
33
33
 
@@ -36,7 +36,9 @@
36
36
  Do Until lngRow > lngRowKousuEnd
37
37
  '2020/08/21 14:29 upd start
38
38
  ' dctRowKomoku.Add wshKousu.Cells(lngRow, cnsColKousuKomoku).Value, lngRow
39
+ If Trim(wshKousu.Cells(lngRow, cnsColKousuKomoku).Value) <> "" Then
39
- dctRowKomoku.Add Trim(wshKousu.Cells(lngRow, cnsColKousuKomoku).Value), lngRow
40
+ dctRowKomoku.Add Trim(wshKousu.Cells(lngRow, cnsColKousuKomoku).Value), lngRow
41
+ End If
40
42
  '2020/08/21 14:29 upd end
41
43
  lngRow = wshKousu.Cells(lngRow, cnsColKousuKomoku).End(xlDown).Row
42
44
  Loop

5

私の個人的な情報を削除

2020/08/21 07:01

投稿

kitasue
kitasue

スコア314

answer CHANGED
@@ -27,7 +27,7 @@
27
27
  Set dctRowKomoku = New Dictionary
28
28
  Set dctColHizuke = New Dictionary
29
29
 
30
- strPath = "C:\Users\kitasue\Documents\工数表は５シート目.xlsm"
30
+ strPath = "工数表は５シート目.xlsm"
31
31
  Set wbkKousu = Workbooks.Open(strPath)
32
32
  Set wshKousu = wbkKousu.Worksheets(5)
33
33
 

4

集計値を初期クリアする処理を追加

2020/08/21 06:28

投稿

kitasue
kitasue

スコア314

answer CHANGED
@@ -27,7 +27,7 @@
27
27
  Set dctRowKomoku = New Dictionary
28
28
  Set dctColHizuke = New Dictionary
29
29
 
30
- strPath = "工数表は５シート目.xlsm"
30
+ strPath = "C:\Users\kitasue\Documents\工数表は５シート目.xlsm"
31
31
  Set wbkKousu = Workbooks.Open(strPath)
32
32
  Set wshKousu = wbkKousu.Worksheets(5)
33
33
 
@@ -45,9 +45,9 @@
45
45
  For lngCol = cnsColKousuBgn To lngColKousuEnd
46
46
  dctColHizuke.Add wshKousu.Cells(cnsRowKousuHizuke, lngCol).Value, lngCol
47
47
  Next lngCol
48
-
48
+ '2020/08/21 15:25 add start
49
49
  wshKousu.Range(wshKousu.Cells(cnsRowKousuBgn, cnsColKousuBgn), wshKousu.Cells(lngRowKousuEnd, lngColKousuEnd)).ClearComments
50
-
50
+ '2020/08/21 15:25 add end
51
51
  For lngWshNum = 1 To ThisWorkbook.Worksheets.Count
52
52
  With ThisWorkbook.Worksheets(lngWshNum)
53
53
  lngColYoteiEnd = cnsColYoteiBgn + 12

3

Const値を変更

2020/08/21 06:27

投稿

kitasue
kitasue

スコア314

answer CHANGED
@@ -2,12 +2,12 @@
2
2
  ```VBA
3
3
  Sub KosuBook()
4
4
  Const cnsRowKousuHizuke = 3
5
- Const cnsRowKousuBgn = 3
5
+ Const cnsRowKousuBgn = 4
6
6
  Const cnsColKousuKomoku = 4
7
7
  Const cnsColKousuBgn = 13
8
8
  Const cnsRowYoteiHizuke = 1
9
9
  Const cnsRowYoteiBgn = 3
10
- Const cnsColYoteiBgn = 10
10
+ Const cnsColYoteiBgn = 6
11
11
 
12
12
  Dim wbkKousu As Workbook
13
13
  Dim wshKousu As Worksheet

2

日付行を３行目に変更

2020/08/21 06:24

投稿

kitasue
kitasue

スコア314

answer CHANGED
@@ -1,7 +1,7 @@
1
1
  マクロを予定表側に組んでみました。
2
2
  ```VBA
3
3
  Sub KosuBook()
4
- Const cnsRowKousuHizuke = 2
4
+ Const cnsRowKousuHizuke = 3
5
5
  Const cnsRowKousuBgn = 3
6
6
  Const cnsColKousuKomoku = 4
7
7
  Const cnsColKousuBgn = 13

1

項目名から空白を削除してみた

2020/08/21 05:43

投稿

kitasue
kitasue

スコア314

answer CHANGED
@@ -34,7 +34,10 @@
34
34
  lngRowKousuEnd = wshKousu.Cells(Rows.Count, cnsColKousuKomoku).End(xlUp).Row
35
35
  lngRow = cnsRowKousuBgn
36
36
  Do Until lngRow > lngRowKousuEnd
37
+ '2020/08/21 14:29 upd start
38
+ ' dctRowKomoku.Add wshKousu.Cells(lngRow, cnsColKousuKomoku).Value, lngRow
37
- dctRowKomoku.Add wshKousu.Cells(lngRow, cnsColKousuKomoku).Value, lngRow
39
+ dctRowKomoku.Add Trim(wshKousu.Cells(lngRow, cnsColKousuKomoku).Value), lngRow
40
+ '2020/08/21 14:29 upd end
38
41
  lngRow = wshKousu.Cells(lngRow, cnsColKousuKomoku).End(xlDown).Row
39
42
  Loop
40
43
 
@@ -43,13 +46,18 @@
43
46
  dctColHizuke.Add wshKousu.Cells(cnsRowKousuHizuke, lngCol).Value, lngCol
44
47
  Next lngCol
45
48
 
49
+ wshKousu.Range(wshKousu.Cells(cnsRowKousuBgn, cnsColKousuBgn), wshKousu.Cells(lngRowKousuEnd, lngColKousuEnd)).ClearComments
50
+
46
51
  For lngWshNum = 1 To ThisWorkbook.Worksheets.Count
47
52
  With ThisWorkbook.Worksheets(lngWshNum)
48
53
  lngColYoteiEnd = cnsColYoteiBgn + 12
49
54
  For lngCol = cnsColYoteiBgn To lngColYoteiEnd Step 2
50
55
  lngRowYoteiEnd = .Cells(Rows.Count, lngCol).End(xlUp).Row
51
56
  For lngRow = cnsRowYoteiBgn To lngRowYoteiEnd
57
+ '2020/08/21 14:29 upd start
58
+ ' lngRowKousu = dctRowKomoku.Item(.Cells(lngRow, lngCol).Value)
52
- lngRowKousu = dctRowKomoku.Item(.Cells(lngRow, lngCol).Value)
59
+ lngRowKousu = dctRowKomoku.Item(Trim(.Cells(lngRow, lngCol).Value))
60
+ '2020/08/21 14:29 upd end
53
61
  lngColKousu = dctColHizuke.Item(.Cells(cnsRowYoteiHizuke, lngCol - 1).Value)
54
62
  If lngRowKousu > 0 And lngColKousu > 0 Then
55
63
  wshKousu.Cells(lngRowKousu, lngColKousu).Value = wshKousu.Cells(lngRowKousu, lngColKousu).Value + 0.5