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

編集履歴

回答編集履歴

9

修正

2021/07/29 03:52

投稿

jinoji
jinoji

スコア4592

answer CHANGED
@@ -40,7 +40,7 @@
40
40
  ```
41
41
 
42
42
  ---
43
- （再々々修正）
43
+ （再々々々修正）
44
44
  ```VBA
45
45
  Sub Macro2()
46
46
 
@@ -57,10 +57,11 @@
57
57
  For i = 2 To LastRow
58
58
  Set Sht2 = Sheets(Sht1.Cells(i, "C").Value)
59
59
  j = Sht2.Cells(Rows.Count, 2).End(xlUp).Row + 1
60
- Dim k
60
+ Dim k, v
61
61
  For k = 2 To Sht2.Cells(2, Columns.Count).End(xlToLeft).Column
62
+ v = WorksheetFunction.Clean(Sht2.Cells(2, k).Value)
62
- If WorksheetFunction.CountIf(Sht1.Rows(1), Sht2.Cells(2, k).Value) > 0 Then
63
+ If WorksheetFunction.CountIf(Sht1.Rows(1), v) > 0 Then
63
- Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
64
+ Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(v, Sht1.Rows(1), False)).Value
64
65
  End If
65
66
  Next k
66
67
  Sht2.Cells.Rows(3).Copy
@@ -72,8 +73,9 @@
72
73
  j = Sht2.Cells(Rows.Count, 2).End(xlUp).Row + 1
73
74
  Dim k
74
75
  For k = 2 To Sht2.Cells(2, Columns.Count).End(xlToLeft).Column
76
+ v = WorksheetFunction.Clean(Sht2.Cells(2, k).Value)
75
- If WorksheetFunction.CountIf(Sht1.Rows(1), Sht2.Cells(2, k).Value) > 0 Then
77
+ If WorksheetFunction.CountIf(Sht1.Rows(1), v) > 0 Then
76
- Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
78
+ Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(v, Sht1.Rows(1), False)).Value
77
79
  End If
78
80
  Next k
79
81
  Sht2.Cells.Rows(3).Copy

8

修正

2021/07/29 03:52

投稿

jinoji
jinoji

スコア4592

answer CHANGED
@@ -40,7 +40,7 @@
40
40
  ```
41
41
 
42
42
  ---
43
- （再々修正）
43
+ （再々々修正）
44
44
  ```VBA
45
45
  Sub Macro2()
46
46
 
@@ -62,9 +62,9 @@
62
62
  If WorksheetFunction.CountIf(Sht1.Rows(1), Sht2.Cells(2, k).Value) > 0 Then
63
63
  Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
64
64
  End If
65
- Next
65
+ Next k
66
66
  Sht2.Cells.Rows(3).Copy
67
- Sht2.Cells.Rows(3).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
67
+ Sht2.Cells.Rows(j).PasteSpecial Paste:=xlPasteFormats
68
68
  Next i
69
69
 
70
70
  For i = 2 To LastRow
@@ -75,9 +75,9 @@
75
75
  If WorksheetFunction.CountIf(Sht1.Rows(1), Sht2.Cells(2, k).Value) > 0 Then
76
76
  Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
77
77
  End If
78
- Next
78
+ Next k
79
79
  Sht2.Cells.Rows(3).Copy
80
- Sht2.Cells.Rows(3).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
80
+ Sht2.Cells.Rows(j).PasteSpecial Paste:=xlPasteFormats
81
81
  Next i
82
82
  End Sub
83
83
 

7

修正

2021/07/29 03:38

投稿

jinoji
jinoji

スコア4592

answer CHANGED
@@ -31,8 +31,8 @@
31
31
  j = j + 1
32
32
  End If
33
33
  Next i
34
- Sht2.Cells.Rows(2).Copy
34
+ Sht2.Cells.Rows(3).Copy
35
- Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
35
+ Sht2.Cells.Rows(3).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
36
36
 
37
37
  End Sub
38
38
 
@@ -40,7 +40,7 @@
40
40
  ```
41
41
 
42
42
  ---
43
- （再修正）
43
+ （再々修正）
44
44
  ```VBA
45
45
  Sub Macro2()
46
46
 
@@ -63,8 +63,8 @@
63
63
  Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
64
64
  End If
65
65
  Next
66
- Sht2.Cells.Rows(2).Copy
66
+ Sht2.Cells.Rows(3).Copy
67
- Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
67
+ Sht2.Cells.Rows(3).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
68
68
  Next i
69
69
 
70
70
  For i = 2 To LastRow
@@ -76,8 +76,8 @@
76
76
  Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
77
77
  End If
78
78
  Next
79
- Sht2.Cells.Rows(2).Copy
79
+ Sht2.Cells.Rows(3).Copy
80
- Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
80
+ Sht2.Cells.Rows(3).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
81
81
  Next i
82
82
  End Sub
83
83
 

6

修正

2021/07/29 03:30

投稿

jinoji
jinoji

スコア4592

answer CHANGED
@@ -40,7 +40,7 @@
40
40
  ```
41
41
 
42
42
  ---
43
- （7/29修正）
43
+ （再修正）
44
44
  ```VBA
45
45
  Sub Macro2()
46
46
 
@@ -73,7 +73,7 @@
73
73
  Dim k
74
74
  For k = 2 To Sht2.Cells(2, Columns.Count).End(xlToLeft).Column
75
75
  If WorksheetFunction.CountIf(Sht1.Rows(1), Sht2.Cells(2, k).Value) > 0 Then
76
- Sht2.Cells(j, k).Value = Sht2.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
76
+ Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
77
77
  End If
78
78
  Next
79
79
  Sht2.Cells.Rows(2).Copy

5

修正

2021/07/29 03:28

投稿

jinoji
jinoji

スコア4592

answer CHANGED
@@ -40,7 +40,8 @@
40
40
  ```
41
41
 
42
42
  ---
43
+ （7/29修正）
43
- ```ここに言語を入力
44
+ ```VBA
44
45
  Sub Macro2()
45
46
 
46
47
  Dim Sht1 As Worksheet
@@ -59,7 +60,7 @@
59
60
  Dim k
60
61
  For k = 2 To Sht2.Cells(2, Columns.Count).End(xlToLeft).Column
61
62
  If WorksheetFunction.CountIf(Sht1.Rows(1), Sht2.Cells(2, k).Value) > 0 Then
62
- Sht2.Cells(j, k).Value = Sht2.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
63
+ Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
63
64
  End If
64
65
  Next
65
66
  Sht2.Cells.Rows(2).Copy

4

修正

2021/07/29 02:58

投稿

jinoji
jinoji

スコア4592

answer CHANGED
@@ -54,7 +54,7 @@
54
54
  Set Sht1 = Sheets("計算用")
55
55
  LastRow = Sht1.Cells(Rows.Count, 2).End(xlUp).Row
56
56
  For i = 2 To LastRow
57
- Set Sht2 = Sheets(Sht1.Cells(i, 3).Value)
57
+ Set Sht2 = Sheets(Sht1.Cells(i, "C").Value)
58
58
  j = Sht2.Cells(Rows.Count, 2).End(xlUp).Row + 1
59
59
  Dim k
60
60
  For k = 2 To Sht2.Cells(2, Columns.Count).End(xlToLeft).Column
@@ -62,10 +62,22 @@
62
62
  Sht2.Cells(j, k).Value = Sht2.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
63
63
  End If
64
64
  Next
65
+ Sht2.Cells.Rows(2).Copy
66
+ Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
65
67
  Next i
68
+
69
+ For i = 2 To LastRow
70
+ Set Sht2 = Sheets(Sht1.Cells(i, "D").Value)
71
+ j = Sht2.Cells(Rows.Count, 2).End(xlUp).Row + 1
72
+ Dim k
73
+ For k = 2 To Sht2.Cells(2, Columns.Count).End(xlToLeft).Column
74
+ If WorksheetFunction.CountIf(Sht1.Rows(1), Sht2.Cells(2, k).Value) > 0 Then
75
+ Sht2.Cells(j, k).Value = Sht2.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
76
+ End If
77
+ Next
66
- Sht2.Cells.Rows(2).Copy
78
+ Sht2.Cells.Rows(2).Copy
67
- Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
79
+ Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
68
-
80
+ Next i
69
81
  End Sub
70
82
 
71
83
  ```

3

追記

2021/07/28 13:40

投稿

jinoji
jinoji

スコア4592

answer CHANGED
@@ -37,4 +37,35 @@
37
37
  End Sub
38
38
 
39
39
 
40
+ ```
41
+
42
+ ---
43
+ ```ここに言語を入力
44
+ Sub Macro2()
45
+
46
+ Dim Sht1 As Worksheet
47
+ Dim Sht2 As Worksheet
48
+ Dim LastRow As Long
49
+ Dim i As Long
50
+ Dim j As Long
51
+ Dim SearchWord As String
52
+
53
+
54
+ Set Sht1 = Sheets("計算用")
55
+ LastRow = Sht1.Cells(Rows.Count, 2).End(xlUp).Row
56
+ For i = 2 To LastRow
57
+ Set Sht2 = Sheets(Sht1.Cells(i, 3).Value)
58
+ j = Sht2.Cells(Rows.Count, 2).End(xlUp).Row + 1
59
+ Dim k
60
+ For k = 2 To Sht2.Cells(2, Columns.Count).End(xlToLeft).Column
61
+ If WorksheetFunction.CountIf(Sht1.Rows(1), Sht2.Cells(2, k).Value) > 0 Then
62
+ Sht2.Cells(j, k).Value = Sht2.Cells(i, WorksheetFunction.Match(Sht2.Cells(2, k).Value, Sht1.Rows(1), False)).Value
63
+ End If
64
+ Next
65
+ Next i
66
+ Sht2.Cells.Rows(2).Copy
67
+ Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
68
+
69
+ End Sub
70
+
40
71
  ```

2

修正

2021/07/28 11:06

投稿

jinoji
jinoji

スコア4592

answer CHANGED
@@ -1,4 +1,4 @@
1
- こんな感じでどうでしょうか。
1
+ こんな感じでどうでしょうか。（修正しました）
2
2
  ```VBA
3
3
  Sub Macro1()
4
4
 
@@ -10,7 +10,7 @@
10
10
  Dim SearchWord As String
11
11
 
12
12
 
13
- SearchWord = InputBox("どこ？", "利用スポット入力", "新宿")
13
+ SearchWord = InputBox("どこ？", "会場入力", "新宿")
14
14
 
15
15
  Set Sht1 = Sheets("計算用")
16
16
  Set Sht2 = Sheets(SearchWord)
@@ -18,22 +18,23 @@
18
18
  Dim arr, k
19
19
  arr = Sht1.UsedRange.Resize(1).Value
20
20
  For k = 1 To UBound(arr, 2)
21
- arr(1, k) = WorksheetFunction.Match(arr(1, k), Sht2.Rows(2), False)
21
+ arr(1, k) = IIf(WorksheetFunction.CountIf(Sht2.Rows(2), arr(1, k)) > 0, WorksheetFunction.Match(arr(1, k), Sht2.Rows(2), False), 0)
22
22
  Next
23
23
 
24
24
  j = 2
25
- LastRow = Sht1.Cells(Rows.Count, 3).End(xlUp).Row
25
+ LastRow = Sht1.Cells(Rows.Count, 2).End(xlUp).Row
26
26
  For i = 2 To LastRow
27
- If InStr(Sht1.Cells(i, 3), SearchWord) > 0 Then
27
+ If InStr(Sht1.Cells(i, 2), SearchWord) > 0 Then
28
28
  For k = 1 To UBound(arr, 2)
29
- Sht2.Cells(j, arr(1, k)).Value = Sht1.Cells(i, k).Value
29
+ If arr(1, k) > 0 Then Sht2.Cells(j, arr(1, k)).Value = Sht1.Cells(i, k).Value
30
30
  Next
31
31
  j = j + 1
32
32
  End If
33
33
  Next i
34
- Sht2.Rows(2).Copy
34
+ Sht2.Cells.Rows(2).Copy
35
- Sht2.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
35
+ Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
36
36
 
37
37
  End Sub
38
38
 
39
+
39
40
  ```

1

修正

2021/07/28 10:55

投稿

jinoji
jinoji

スコア4592

answer CHANGED
@@ -31,8 +31,8 @@
31
31
  j = j + 1
32
32
  End If
33
33
  Next i
34
- Sht2.Cells.Rows(2).Copy
34
+ Sht2.Rows(2).Copy
35
- Sht2.Cells.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
35
+ Sht2.Rows(2).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
36
36
 
37
37
  End Sub
38
38