teratail
回答率
85.46%
質問するログイン新規登録
トップVBAに関する質問EXCEL VBA マクロ 別シート コピペ 特定の値

編集履歴

回答編集履歴

9

修正

2021/07/29 03:52

投稿

jinoji
jinoji

スコア4585

test CHANGED
@@ -82,7 +82,7 @@
82
82
 
83
83
  ---
84
84
 
85
- （再々々修正）
85
+ （再々々々修正）
86
86
 
87
87
  ```VBA
88
88
 
@@ -116,13 +116,15 @@
116
116
 
117
117
  j = Sht2.Cells(Rows.Count, 2).End(xlUp).Row + 1
118
118
 
119
- Dim k
119
+ Dim k, v
120
120
 
121
121
  For k = 2 To Sht2.Cells(2, Columns.Count).End(xlToLeft).Column
122
122
 
123
- If WorksheetFunction.CountIf(Sht1.Rows(1), Sht2.Cells(2, k).Value) > 0 Then
123
+ v = WorksheetFunction.Clean(Sht2.Cells(2, k).Value)
124
124
 
125
+ If WorksheetFunction.CountIf(Sht1.Rows(1), v) > 0 Then
126
+
125
- Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
127
+ Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(v, Sht1.Rows(1), False)).Value
126
128
 
127
129
  End If
128
130
 
@@ -146,9 +148,11 @@
146
148
 
147
149
  For k = 2 To Sht2.Cells(2, Columns.Count).End(xlToLeft).Column
148
150
 
149
- If WorksheetFunction.CountIf(Sht1.Rows(1), Sht2.Cells(2, k).Value) > 0 Then
151
+ v = WorksheetFunction.Clean(Sht2.Cells(2, k).Value)
150
152
 
153
+ If WorksheetFunction.CountIf(Sht1.Rows(1), v) > 0 Then
154
+
151
- Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
155
+ Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(v, Sht1.Rows(1), False)).Value
152
156
 
153
157
  End If
154
158
 

8

修正

2021/07/29 03:52

投稿

jinoji
jinoji

スコア4585

test CHANGED
@@ -82,7 +82,7 @@
82
82
 
83
83
  ---
84
84
 
85
- （再々修正）
85
+ （再々々修正）
86
86
 
87
87
  ```VBA
88
88
 
@@ -126,11 +126,11 @@
126
126
 
127
127
  End If
128
128
 
129
- Next
129
+ Next k
130
130
 
131
131
  Sht2.Cells.Rows(3).Copy
132
132
 
133
- Sht2.Cells.Rows(3).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
133
+ Sht2.Cells.Rows(j).PasteSpecial Paste:=xlPasteFormats
134
134
 
135
135
  Next i
136
136
 
@@ -152,11 +152,11 @@
152
152
 
153
153
  End If
154
154
 
155
- Next
155
+ Next k
156
156
 
157
157
  Sht2.Cells.Rows(3).Copy
158
158
 
159
- Sht2.Cells.Rows(3).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
159
+ Sht2.Cells.Rows(j).PasteSpecial Paste:=xlPasteFormats
160
160
 
161
161
  Next i
162
162
 

7

修正

2021/07/29 03:38

投稿

jinoji
jinoji

スコア4585

test CHANGED
@@ -64,9 +64,9 @@
64
64
 
65
65
  Next i
66
66
 
67
- Sht2.Cells.Rows(2).Copy
67
+ Sht2.Cells.Rows(3).Copy
68
68
 
69
- Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
69
+ Sht2.Cells.Rows(3).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
70
70
 
71
71
 
72
72
 
@@ -82,7 +82,7 @@
82
82
 
83
83
  ---
84
84
 
85
- （再修正）
85
+ （再々修正）
86
86
 
87
87
  ```VBA
88
88
 
@@ -128,9 +128,9 @@
128
128
 
129
129
  Next
130
130
 
131
- Sht2.Cells.Rows(2).Copy
131
+ Sht2.Cells.Rows(3).Copy
132
132
 
133
- Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
133
+ Sht2.Cells.Rows(3).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
134
134
 
135
135
  Next i
136
136
 
@@ -154,9 +154,9 @@
154
154
 
155
155
  Next
156
156
 
157
- Sht2.Cells.Rows(2).Copy
157
+ Sht2.Cells.Rows(3).Copy
158
158
 
159
- Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
159
+ Sht2.Cells.Rows(3).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
160
160
 
161
161
  Next i
162
162
 

6

修正

2021/07/29 03:30

投稿

jinoji
jinoji

スコア4585

test CHANGED
@@ -82,7 +82,7 @@
82
82
 
83
83
  ---
84
84
 
85
- （7/29修正）
85
+ （再修正）
86
86
 
87
87
  ```VBA
88
88
 
@@ -148,7 +148,7 @@
148
148
 
149
149
  If WorksheetFunction.CountIf(Sht1.Rows(1), Sht2.Cells(2, k).Value) > 0 Then
150
150
 
151
- Sht2.Cells(j, k).Value = Sht2.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
151
+ Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
152
152
 
153
153
  End If
154
154
 

5

修正

2021/07/29 03:28

投稿

jinoji
jinoji

スコア4585

test CHANGED
@@ -82,7 +82,9 @@
82
82
 
83
83
  ---
84
84
 
85
+ （7/29修正）
86
+
85
- ```ここに言語を入力
87
+ ```VBA
86
88
 
87
89
  Sub Macro2()
88
90
 
@@ -120,7 +122,7 @@
120
122
 
121
123
  If WorksheetFunction.CountIf(Sht1.Rows(1), Sht2.Cells(2, k).Value) > 0 Then
122
124
 
123
- Sht2.Cells(j, k).Value = Sht2.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
125
+ Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
124
126
 
125
127
  End If
126
128
 

4

修正

2021/07/29 02:58

投稿

jinoji
jinoji

スコア4585

test CHANGED
@@ -110,7 +110,7 @@
110
110
 
111
111
  For i = 2 To LastRow
112
112
 
113
- Set Sht2 = Sheets(Sht1.Cells(i, 3).Value)
113
+ Set Sht2 = Sheets(Sht1.Cells(i, "C").Value)
114
114
 
115
115
  j = Sht2.Cells(Rows.Count, 2).End(xlUp).Row + 1
116
116
 
@@ -126,13 +126,37 @@
126
126
 
127
127
  Next
128
128
 
129
+ Sht2.Cells.Rows(2).Copy
130
+
131
+ Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
132
+
129
133
  Next i
130
134
 
131
- Sht2.Cells.Rows(2).Copy
132
135
 
133
- Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
134
136
 
135
-
137
+ For i = 2 To LastRow
138
+
139
+ Set Sht2 = Sheets(Sht1.Cells(i, "D").Value)
140
+
141
+ j = Sht2.Cells(Rows.Count, 2).End(xlUp).Row + 1
142
+
143
+ Dim k
144
+
145
+ For k = 2 To Sht2.Cells(2, Columns.Count).End(xlToLeft).Column
146
+
147
+ If WorksheetFunction.CountIf(Sht1.Rows(1), Sht2.Cells(2, k).Value) > 0 Then
148
+
149
+ Sht2.Cells(j, k).Value = Sht2.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
150
+
151
+ End If
152
+
153
+ Next
154
+
155
+ Sht2.Cells.Rows(2).Copy
156
+
157
+ Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
158
+
159
+ Next i
136
160
 
137
161
  End Sub
138
162
 

3

追記

2021/07/28 13:40

投稿

jinoji
jinoji

スコア4585

test CHANGED
@@ -77,3 +77,65 @@
77
77
 
78
78
 
79
79
  ```
80
+
81
+
82
+
83
+ ---
84
+
85
+ ```ここに言語を入力
86
+
87
+ Sub Macro2()
88
+
89
+
90
+
91
+ Dim Sht1 As Worksheet
92
+
93
+ Dim Sht2 As Worksheet
94
+
95
+ Dim LastRow As Long
96
+
97
+ Dim i As Long
98
+
99
+ Dim j As Long
100
+
101
+ Dim SearchWord As String
102
+
103
+
104
+
105
+
106
+
107
+ Set Sht1 = Sheets("計算用")
108
+
109
+ LastRow = Sht1.Cells(Rows.Count, 2).End(xlUp).Row
110
+
111
+ For i = 2 To LastRow
112
+
113
+ Set Sht2 = Sheets(Sht1.Cells(i, 3).Value)
114
+
115
+ j = Sht2.Cells(Rows.Count, 2).End(xlUp).Row + 1
116
+
117
+ Dim k
118
+
119
+ For k = 2 To Sht2.Cells(2, Columns.Count).End(xlToLeft).Column
120
+
121
+ If WorksheetFunction.CountIf(Sht1.Rows(1), Sht2.Cells(2, k).Value) > 0 Then
122
+
123
+ Sht2.Cells(j, k).Value = Sht2.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
124
+
125
+ End If
126
+
127
+ Next
128
+
129
+ Next i
130
+
131
+ Sht2.Cells.Rows(2).Copy
132
+
133
+ Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
134
+
135
+
136
+
137
+ End Sub
138
+
139
+
140
+
141
+ ```

2

修正

2021/07/28 11:06

投稿

jinoji
jinoji

スコア4585

test CHANGED
@@ -1,4 +1,4 @@
1
- こんな感じでどうでしょうか。
1
+ こんな感じでどうでしょうか。（修正しました）
2
2
 
3
3
  ```VBA
4
4
 
@@ -22,7 +22,7 @@
22
22
 
23
23
 
24
24
 
25
- SearchWord = InputBox("どこ？", "利用スポット入力", "新宿")
25
+ SearchWord = InputBox("どこ？", "会場入力", "新宿")
26
26
 
27
27
 
28
28
 
@@ -38,7 +38,7 @@
38
38
 
39
39
  For k = 1 To UBound(arr, 2)
40
40
 
41
- arr(1, k) = WorksheetFunction.Match(arr(1, k), Sht2.Rows(2), False)
41
+ arr(1, k) = IIf(WorksheetFunction.CountIf(Sht2.Rows(2), arr(1, k)) > 0, WorksheetFunction.Match(arr(1, k), Sht2.Rows(2), False), 0)
42
42
 
43
43
  Next
44
44
 
@@ -46,15 +46,15 @@
46
46
 
47
47
  j = 2
48
48
 
49
- LastRow = Sht1.Cells(Rows.Count, 3).End(xlUp).Row
49
+ LastRow = Sht1.Cells(Rows.Count, 2).End(xlUp).Row
50
50
 
51
51
  For i = 2 To LastRow
52
52
 
53
- If InStr(Sht1.Cells(i, 3), SearchWord) > 0 Then
53
+ If InStr(Sht1.Cells(i, 2), SearchWord) > 0 Then
54
54
 
55
55
  For k = 1 To UBound(arr, 2)
56
56
 
57
- Sht2.Cells(j, arr(1, k)).Value = Sht1.Cells(i, k).Value
57
+ If arr(1, k) > 0 Then Sht2.Cells(j, arr(1, k)).Value = Sht1.Cells(i, k).Value
58
58
 
59
59
  Next
60
60
 
@@ -64,9 +64,9 @@
64
64
 
65
65
  Next i
66
66
 
67
- Sht2.Rows(2).Copy
67
+ Sht2.Cells.Rows(2).Copy
68
68
 
69
- Sht2.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
69
+ Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
70
70
 
71
71
 
72
72
 
@@ -74,4 +74,6 @@
74
74
 
75
75
 
76
76
 
77
+
78
+
77
79
  ```

1

修正

2021/07/28 10:55

投稿

jinoji
jinoji

スコア4585

test CHANGED
@@ -64,9 +64,9 @@
64
64
 
65
65
  Next i
66
66
 
67
- Sht2.Cells.Rows(2).Copy
67
+ Sht2.Rows(2).Copy
68
68
 
69
- Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
69
+ Sht2.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
70
70
 
71
71
 
72
72