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

回答編集履歴

1

追記

2021/07/17 03:13

投稿

jinoji
jinoji

スコア4592

answer CHANGED
@@ -1,3 +1,79 @@
1
+ <追記>
2
+ ```VBA
3
+ Sub 一致転記2()
4
+
5
+ '開始時間
6
+ Dim ST As Single, ET As Single
7
+ ST = Timer
8
+
9
+ '表示抑制
10
+ With Application
11
+ .ScreenUpdating = False
12
+ .DisplayAlerts = False
13
+ End With
14
+
15
+ '配列作成
16
+ Dim ws1rng As Range, ws1data As Variant
17
+ With ThisWorkbook.Sheets("出力")
18
+ Set ws1rng = .Range("A1", .Cells.SpecialCells(xlCellTypeLastCell))
19
+ ws1data = ws1rng.Value
20
+ End With
21
+ Dim ws2rng As Range, ws2data As Variant
22
+ With ThisWorkbook.Sheets("データ元")
23
+ Set ws2rng = .Range("A1", .Cells.SpecialCells(xlCellTypeLastCell))
24
+ ws2data = ws2rng.Value
25
+ End With
26
+ Dim ws3rng As Range, ws3data As Variant
27
+ With ThisWorkbook.Sheets("マスタ")
28
+ Set ws3rng = .Range("A1", .Cells.SpecialCells(xlCellTypeLastCell))
29
+ ws3data = ws3rng.Value
30
+ End With
31
+
32
+ '辞書作成
33
+ Dim m, i, k, v
34
+ Set m = CreateObject("Scripting.Dictionary")
35
+ For i = 3 To UBound(ws3data, 1)
36
+ k = ws3data(i, 2)
37
+ v = ws3data(i, 6)
38
+ m(k) = v
39
+ Next
40
+
41
+ '辞書適用
42
+ Dim d
43
+ Set d = CreateObject("Scripting.Dictionary")
44
+ For i = 2 To UBound(ws2data, 1)
45
+ k = ws2data(i, 2) & ws2data(i, 4)
46
+ If m.Exists(k) Then
47
+ ws2data(i, 14) = m(k)
48
+ d(k) = ws2data(i, 14)
49
+ End If
50
+ Next
51
+ For i = 2 To UBound(ws1data, 1)
52
+ k = ws1data(i, 2) & ws1data(i, 3)
53
+ If d.Exists(k) Then
54
+ ws1data(i, 6) = d(k)
55
+ End If
56
+ Next
57
+
58
+ '配列出力
59
+ ws1rng.Value = ws1data
60
+ ws2rng.Value = ws2data
61
+
62
+ '抑制解除
63
+ With Application
64
+ .ScreenUpdating = True
65
+ .DisplayAlerts = True
66
+ End With
67
+
68
+ '終了時間
69
+ ET = Timer - ST
70
+ MsgBox Round(ET / 60, 0) & "." & Round(ET Mod 60, 0)
71
+
72
+ End Sub
73
+
74
+ ```
75
+ ---
76
+ <追記前>
1
77
  他の方とそんなに変わらないので載せる意味も乏しいですが。
2
78
  ```VBA
3
79
  Sub 一致転記()