teratail header banner
teratail header banner
質問するログイン新規登録

回答編集履歴

3

追記

2021/02/25 07:08

投稿

jinoji
jinoji

スコア4592

answer CHANGED
@@ -1,4 +1,53 @@
1
1
  私ならDictionaryを使うと思います。
2
2
  一致表を行ごとに読んで辞書にする(Keyは内容&項目&対応をつなげる、Itemは表示項目)
3
3
  検索表を行ごとに読んで、同じようにKeyを作り、そのKEYで辞書から探し、
4
- 見つかったらそれを書く、見つからなければその旨書く
4
+ 見つかったらそれを書く、見つからなければその旨書く
5
+
6
+ ---
7
+ ```VBA
8
+
9
+ Sub sample()
10
+ Dim ws As Worksheet
11
+ Set ws = ActiveSheet
12
+
13
+ Dim dic As Scripting.Dictionary
14
+ Set dic = CreateObject("Scripting.Dictionary")
15
+
16
+ Dim 一致表 As Range
17
+ Set 一致表 = ws.Range("E1").CurrentRegion
18
+ With 一致表
19
+ Dim i, k, v
20
+ For i = 3 To .Rows.Count
21
+ k = TabJoin(.Cells(i, 1).Resize(, .Columns.Count - 1).Value)
22
+ v = .Cells(i, .Columns.Count).Value
23
+ dic.Add k, v
24
+ Next
25
+ End With
26
+
27
+ Dim 検索表 As Range
28
+ Set 検索表 = ws.Range("A1").CurrentRegion
29
+ With 検索表
30
+ Dim j, s, outCell As Range
31
+ For j = 3 To .Rows.Count
32
+ Set outCell = ws.Cells(.Rows.Count + j, 1)
33
+
34
+ s = TabJoin(.Rows(j).Value)
35
+
36
+ If dic.Exists(s) Then
37
+ outCell.Value = dic(s)
38
+ Else
39
+ outCell.Value = "入力する"
40
+ outCell.Interior.Color = vbYellow
41
+ End If
42
+ Next
43
+ ws.Cells(.Rows.Count + 2, 1).Value = "結果"
44
+ End With
45
+ End Sub
46
+
47
+ Function TabJoin(r)
48
+ With WorksheetFunction
49
+ ' TabJoin = .TextJoin(vbTab, True, r)
50
+ TabJoin = Join(.Transpose(.Transpose(r)), vbTab)
51
+ End With
52
+ End Function
53
+ ```

2

修正

2021/02/25 07:08

投稿

jinoji
jinoji

スコア4592

answer CHANGED
@@ -1,47 +1,4 @@
1
1
  私ならDictionaryを使うと思います。
2
2
  一致表を行ごとに読んで辞書にする(Keyは内容&項目&対応をつなげる、Itemは表示項目)
3
3
  検索表を行ごとに読んで、同じようにKeyを作り、そのKEYで辞書から探し、
4
- 見つかったらそれを書く、見つからなければその旨書く
4
+ 見つかったらそれを書く、見つからなければその旨書く
5
-
6
- ---
7
- ```VBA
8
- Sub sample()
9
- Dim ws As Worksheet
10
- Set ws = ActiveSheet
11
-
12
- Dim dic As Scripting.Dictionary
13
- Set dic = CreateObject("Scripting.Dictionary")
14
-
15
- Dim 一致表 As Range, i
16
- Set 一致表 = ws.Range("E1").CurrentRegion
17
- With 一致表
18
- For i = 3 To .Rows.Count
19
- dic.Add JoinUs(.Rows(i).Resize(, 3)), .Cells(i, 4).Value
20
- Next
21
- End With
22
-
23
- Dim 検索表 As Range, j, t, outCell As Range
24
-
25
- Set 検索表 = ws.Range("A1").CurrentRegion
26
- With 検索表
27
- For j = 3 To .Rows.Count
28
-
29
- Set outCell.Value = ws.Cells(.Rows.Count + j, 1)
30
-
31
- t = JoinUs(.Rows(j))
32
-
33
- If dic.Exists(t) Then
34
- outCell.Value = dic(t)
35
- Else
36
- outCell.Value = "入力する"
37
- outCell.Interior.Color = vbYellow
38
- End If
39
- Next
40
- End With
41
- End Sub
42
-
43
- Function JoinUs(r)
44
- JoinUs = WorksheetFunction.TextJoin(vbTab, True, r)
45
- End Function
46
-
47
- ```

1

追記

2021/02/25 03:58

投稿

jinoji
jinoji

スコア4592

answer CHANGED
@@ -1,4 +1,47 @@
1
1
  私ならDictionaryを使うと思います。
2
2
  一致表を行ごとに読んで辞書にする(Keyは内容&項目&対応をつなげる、Itemは表示項目)
3
- 検索を行ごとに読んで、同じようにKeyを作り、そのKEYで辞書から探し、
3
+ 検索を行ごとに読んで、同じようにKeyを作り、そのKEYで辞書から探し、
4
- 見つかったらそれを書く、見つからなければその旨書く
4
+ 見つかったらそれを書く、見つからなければその旨書く
5
+
6
+ ---
7
+ ```VBA
8
+ Sub sample()
9
+ Dim ws As Worksheet
10
+ Set ws = ActiveSheet
11
+
12
+ Dim dic As Scripting.Dictionary
13
+ Set dic = CreateObject("Scripting.Dictionary")
14
+
15
+ Dim 一致表 As Range, i
16
+ Set 一致表 = ws.Range("E1").CurrentRegion
17
+ With 一致表
18
+ For i = 3 To .Rows.Count
19
+ dic.Add JoinUs(.Rows(i).Resize(, 3)), .Cells(i, 4).Value
20
+ Next
21
+ End With
22
+
23
+ Dim 検索表 As Range, j, t, outCell As Range
24
+
25
+ Set 検索表 = ws.Range("A1").CurrentRegion
26
+ With 検索表
27
+ For j = 3 To .Rows.Count
28
+
29
+ Set outCell.Value = ws.Cells(.Rows.Count + j, 1)
30
+
31
+ t = JoinUs(.Rows(j))
32
+
33
+ If dic.Exists(t) Then
34
+ outCell.Value = dic(t)
35
+ Else
36
+ outCell.Value = "入力する"
37
+ outCell.Interior.Color = vbYellow
38
+ End If
39
+ Next
40
+ End With
41
+ End Sub
42
+
43
+ Function JoinUs(r)
44
+ JoinUs = WorksheetFunction.TextJoin(vbTab, True, r)
45
+ End Function
46
+
47
+ ```