回答編集履歴

1

コードの追加

2018/06/05 02:44

投稿

hatena19
hatena19

スコア33782

test CHANGED
@@ -21,3 +21,99 @@
21
21
  これなら、一括読み込み、一括出力になりますので、
22
22
 
23
23
  重い処理になるシートのレンジへのアクセスが2回ですみます。
24
+
25
+
26
+
27
+ **サンプルコード**
28
+
29
+ ```vba
30
+
31
+ Public Sub リスト化()
32
+
33
+
34
+
35
+ Dim i As Long, j As Long, c As Long
36
+
37
+ Dim ary1()
38
+
39
+ Dim ary2()
40
+
41
+ Dim maxrow As Long
42
+
43
+
44
+
45
+ Application.ScreenUpdating = False
46
+
47
+ Application.EnableEvents = False
48
+
49
+
50
+
51
+ With Sheets("シート1")
52
+
53
+ maxrow = .Cells(.Rows.Count, 1).End(xlUp).Row
54
+
55
+ ary1 = .Range(.Cells(2, 1), .Cells(maxrow, 8)).Value
56
+
57
+ maxrow = WorksheetFunction.CountA(.Range(.Cells(2, 3), .Cells(maxrow, 8))) \ 2 '出力行数
58
+
59
+ End With
60
+
61
+
62
+
63
+ ReDim ary2(1 To maxrow, 1 To 4) '出力用配列のサイズ確保
64
+
65
+
66
+
67
+ For i = LBound(ary1) To UBound(ary1)
68
+
69
+ For j = 3 To 8 Step 2
70
+
71
+ If ary1(i, j) <> "" Then
72
+
73
+ c = c + 1
74
+
75
+ ary2(c, 1) = ary1(i, 1)
76
+
77
+ ary2(c, 2) = ary1(i, 2)
78
+
79
+ ary2(c, 3) = ary1(i, j)
80
+
81
+ ary2(c, 4) = ary1(i, j + 1)
82
+
83
+ Else
84
+
85
+ Exit For
86
+
87
+ End If
88
+
89
+ Next
90
+
91
+ Next
92
+
93
+
94
+
95
+ With Sheets("シート2")
96
+
97
+ .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ary2), 4).Value = ary2
98
+
99
+ End With
100
+
101
+
102
+
103
+ Application.EnableEvents = True
104
+
105
+ Application.ScreenUpdating = True
106
+
107
+ End Sub
108
+
109
+ ```
110
+
111
+
112
+
113
+ 出力用配列にレイアウト変換して代入する部分のロジックが初心者には難しいかな?
114
+
115
+ コードを読んでもらえれば、それほど難しいことはしてないことがわかると思います。
116
+
117
+
118
+
119
+ あとは、CountA で空白以外のセル件数を取得して、2で割って出力行数を取得するというのを思いつくかですね。