質問編集履歴

1

ソースコード追加

2017/03/10 06:41

投稿

hajimete
hajimete

スコア41

test CHANGED
File without changes
test CHANGED
@@ -42,7 +42,215 @@
42
42
 
43
43
  L列には本文にアンカーといわれるものがついています。
44
44
 
45
-
45
+ """""
46
+
47
+
48
+
49
+ '「reg_date」の値を基に昇順に並び替える
50
+
51
+ Finr = .Range("B1").End(xlDown).Row
52
+
53
+ .Range("A1" & ":AD" & Finr).Sort Key1:=.Range("X1"), order1:=xlAscending, Header:=lYes
54
+
55
+
56
+
57
+
58
+
59
+ '列を挿入する
60
+
61
+ .Columns("F").Insert
62
+
63
+
64
+
65
+ '挿入した列に「=row()-2」を代入
66
+
67
+ .Range("F3" & ":F" & Finr).Value = "=row()-2"
68
+
69
+
70
+
71
+ '1行目(各項目名)をSheet2にコピー
72
+
73
+ Worksheets("Sheet1").Select
74
+
75
+ .Range("A1:AE1").Select
76
+
77
+ Selection.Copy
78
+
79
+ Worksheets("Sheet2").Select
80
+
81
+ Worksheets("Sheet2").Range("A1").Select
82
+
83
+ ActiveSheet.Paste
84
+
85
+
86
+
87
+
88
+
89
+ '「res_count」列の1行目以降に数値が入っているセルを検索し、入っている行を切り取りSheet2にペースト(次スレ以降のタイトル行を削除)
90
+
91
+ DelY = 1
92
+
93
+
94
+
95
+ For i = 1 To R
96
+
97
+
98
+
99
+ If Not .Range("O" & DelY & ":O" & Finr).Find(What:="*", LookIn:=xlValues) Is Nothing Then
100
+
101
+
102
+
103
+ DelY = .Range("A" & DelY & ":A" & Finr).Find(What:="*", LookIn:=xlValues).Row
104
+
105
+
106
+
107
+ If Len(Trim(DelY)) <> 0 Then
108
+
109
+
110
+
111
+ Worksheets("Sheet1").Select
112
+
113
+ .Range("A" & DelY & ":AE" & DelY).Select
114
+
115
+ Selection.Copy
116
+
117
+
118
+
119
+
120
+
121
+ Worksheets("Sheet2").Select
122
+
123
+ Worksheets("Sheet2").Range("A" & (i + 1)).Select
124
+
125
+ ActiveSheet.Paste
126
+
127
+
128
+
129
+ Worksheets("Sheet1").Select
130
+
131
+ .Range("A" & DelY).Select
132
+
133
+
134
+
135
+ If DelY <> 2 Then
136
+
137
+
138
+
139
+ Selection.EntireRow.Delete
140
+
141
+ DelY = DelY - 1
142
+
143
+
144
+
145
+ Else
146
+
147
+
148
+
149
+ .Range("A2").ClearContents
150
+
151
+
152
+
153
+ End If
154
+
155
+
156
+
157
+
158
+
159
+ End If
160
+
161
+
162
+
163
+
164
+
165
+ End If
166
+
167
+
168
+
169
+ Next i
170
+
171
+
172
+
173
+ .Range("A2").Value = "1"
174
+
175
+
176
+
177
+ Worksheets("Sheet2").Select
178
+
179
+ Columns("F").Select
180
+
181
+ Selection.Delete
182
+
183
+ Range("A1").Select
184
+
185
+
186
+
187
+ Worksheets("Sheet1").Select
188
+
189
+
190
+
191
+
192
+
193
+ '「status」列に「1」以外の数字が入っている場合は行ごと削除
194
+
195
+ i = 2
196
+
197
+ Do While i < Finr
198
+
199
+
200
+
201
+ If i <= 1 Then
202
+
203
+
204
+
205
+ MsgBox "タイトル行(スレッドタイトル、本文)が削除されています!OPEでスレッドタイトル、本文が削除されていないか確認し、データダウンロードからやり直してください"
206
+
207
+ Cells.Clear
208
+
209
+ Exit Sub
210
+
211
+
212
+
213
+ End If
214
+
215
+
216
+
217
+ Serc = .Range("R" & i).Value
218
+
219
+
220
+
221
+ If Serc = "1" Then
222
+
223
+
224
+
225
+ i = i + 1
226
+
227
+
228
+
229
+ ElseIf Serc = "" Then
230
+
231
+
232
+
233
+ Exit Do
234
+
235
+
236
+
237
+ Else
238
+
239
+
240
+
241
+ .Rows(i).Delete
242
+
243
+ i = i - 1
244
+
245
+
246
+
247
+ End If
248
+
249
+
250
+
251
+ Loop
252
+
253
+ """""
46
254
 
47
255
  結果
48
256