teratail
回答率
85.35%
teratail header banner
teratail header banner
質問するログイン新規登録
トップVBAに関する質問VBAについて(同じ値でかつ4件までをコピーする方法)

編集履歴

回答編集履歴

5

追記

2020/07/28 19:52

投稿

tosi
tosi

スコア553

test CHANGED
@@ -100,7 +100,7 @@
100
100
 
101
101
  ```
102
102
 
103
- 省略型がありました。追記致します。
103
+ 省略型思いつきました。追記致します。
104
104
 
105
105
  ```VBA
106
106
 

4

再度変更

2020/07/28 19:52

投稿

tosi
tosi

スコア553

test CHANGED
@@ -1,4 +1,4 @@
1
- 複写元Sheet1、複写先Sheet2。
1
+ 複写元Sheet1、複写先Sheet2。(単純複写)
2
2
 
3
3
  ```VBA
4
4
 
@@ -16,9 +16,7 @@
16
16
 
17
17
  ```
18
18
 
19
- 質問内容良く読んでいませんでした。
19
+ 質問内容良く読んでいませんでした。追記します。
20
-
21
- 追記します。
22
20
 
23
21
  ```VBA
24
22
 
@@ -101,3 +99,63 @@
101
99
  End Sub
102
100
 
103
101
  ```
102
+
103
+ 省略型がありました。追記致します。
104
+
105
+ ```VBA
106
+
107
+ Sub Test_Sample_Miniature()
108
+
109
+ Dim MyRange As Range
110
+
111
+ Dim CopyRange As Range
112
+
113
+ Dim lngToRow As Long
114
+
115
+ Dim StaCell As Range
116
+
117
+ Dim EndCell As Range
118
+
119
+ Dim BefCell As Range
120
+
121
+ Dim intMax As Integer
122
+
123
+ Set StaCell = Range("A1")
124
+
125
+ Set EndCell = Range("D1")
126
+
127
+ Set BefCell = Range("D1")
128
+
129
+ lngToRow = 1
130
+
131
+ intMax = 0
132
+
133
+ For Each MyRange In Range("D1:D16")
134
+
135
+ If MyRange.Value <> BefCell.Value Or intMax = 4 Then
136
+
137
+ Set EndCell = BefCell
138
+
139
+ intMax = 0
140
+
141
+ Set CopyRange = Worksheets("Sheet1").Range(StaCell, EndCell)
142
+
143
+ CopyRange.Copy Destination:=Worksheets("Sheet2").Cells(lngToRow, 1)
144
+
145
+ lngToRow = lngToRow + CopyRange.Rows.Count + 1
146
+
147
+ intCount = intCount + 1
148
+
149
+ Set StaCell = Cells(MyRange.Row, 1)
150
+
151
+ End If
152
+
153
+ Set BefCell = MyRange
154
+
155
+ intMax = intMax + 1
156
+
157
+ Next
158
+
159
+ End Sub
160
+
161
+ ```

3

追記

2020/07/28 08:31

投稿

tosi
tosi

スコア553

test CHANGED
@@ -22,7 +22,7 @@
22
22
 
23
23
  ```VBA
24
24
 
25
- Sub test()
25
+ Sub Test_Sample_Miniature()
26
26
 
27
27
  Dim MyRange As Range
28
28
 

2

追記

2020/07/28 01:47

投稿

tosi
tosi

スコア553

test CHANGED
@@ -16,4 +16,88 @@
16
16
 
17
17
  ```
18
18
 
19
- VBA画面からF1キーヘルプで表示させた例と一緒ですね。
19
+ 質問内容良く読んでいませんでした。
20
+
21
+ 追記します。
22
+
23
+ ```VBA
24
+
25
+ Sub test()
26
+
27
+ Dim MyRange As Range
28
+
29
+ Dim StaCell As Range
30
+
31
+ Dim EndCell As Range
32
+
33
+ Dim BefCell As Range
34
+
35
+ Dim intCount As Integer
36
+
37
+ Dim intMax As Integer
38
+
39
+ Set StaCell = Range("A1")
40
+
41
+ Set EndCell = Range("D1")
42
+
43
+ Set BefCell = Range("D1")
44
+
45
+ intCount = 0
46
+
47
+ intMax = 0
48
+
49
+ For Each MyRange In Range("D1:D16")
50
+
51
+ If MyRange.Value <> BefCell.Value Or intMax = 4 Then
52
+
53
+ Set EndCell = BefCell
54
+
55
+ intMax = 0
56
+
57
+ With Worksheets("Sheet1").Range(StaCell, EndCell)
58
+
59
+ Select Case intCount
60
+
61
+ Case 0
62
+
63
+ .Copy Destination:=Worksheets("Sheet2").Range("A1")
64
+
65
+ Case 1
66
+
67
+ .Copy Destination:=Worksheets("Sheet2").Range("A2")
68
+
69
+ Case 2
70
+
71
+ .Copy Destination:=Worksheets("Sheet2").Range("A7")
72
+
73
+ Case 3
74
+
75
+ .Copy Destination:=Worksheets("Sheet2").Range("A9")
76
+
77
+ Case 4
78
+
79
+ .Copy Destination:=Worksheets("Sheet2").Range("A13")
80
+
81
+ Case 5
82
+
83
+ .Copy Destination:=Worksheets("Sheet2").Range("A18")
84
+
85
+ End Select
86
+
87
+ End With
88
+
89
+ intCount = intCount + 1
90
+
91
+ Set StaCell = Cells(MyRange.Row, 1)
92
+
93
+ End If
94
+
95
+ Set BefCell = MyRange
96
+
97
+ intMax = intMax + 1
98
+
99
+ Next
100
+
101
+ End Sub
102
+
103
+ ```

1

'(Test_Sample_Miniature)

2020/07/28 01:46

投稿

tosi
tosi

スコア553

test CHANGED
@@ -1,6 +1,8 @@
1
1
  複写元Sheet1、複写先Sheet2。
2
2
 
3
3
  ```VBA
4
+
5
+ '(Test_Sample_Miniature)
4
6
 
5
7
  Worksheets("Sheet1").Range("A1:D5").Copy Destination:=Worksheets("Sheet2").Range("A1")
6
8