| |
▼わんころもち さん：
おじゃまします。
>力技ですが､1000行で30秒ほどで終わりましたので､自分的にはよしとします｡
事後談みたいですけど、ほんのわずかな修正で、何百倍もスピードアップできますよ。
以下に、気がついたポイントを示します。
▼
Sub 番号検出Type1() '変数の宣言方法を修正(データ型を付す)
'また、書き出し先シートA列の表示形式を「テキスト型」にしておく
Dim Row1 as long, Row2 as long, i as long, Code As Long
Dim Bangou As String
Dim buf As Variant
Dim t As Single '---- Speed Check用
t = Timer
Application.ScreenUpdating = False
With Sheets("証券番号").Columns("A")
.ClearContents
.NumberFormat = "@"
End With
For Row1 = 2 To 1000
ThisWorkbook.Sheets("元データ").Activate
If Cells(Row1, 5).Value Like "*[A-Z][A-Z]#######*" Then
Code = 1
GoSub 文字列切り出し
GoSub 番号書き出し
ElseIf Cells(Row1, 5).Value Like "*##########*" Then
Code = 2
GoSub 文字列切り出し
GoSub 番号書き出し
End If
Next
Application.ScreenUpdating = True
Debug.Print "Type1 "; Timer - t
MsgBox ("番号の書き出しが終わりました") '★ Type1 33.91016
Exit Sub
文字列切り出し:
For i = 1 To Len(Cells(Row1, 5).Value)
If Code = 1 Then
buf = Mid(Cells(Row1, 5).Value, i, 9)
If buf Like "[A-Z][A-Z]#######" Then
Bangou = buf
Exit For
End If
ElseIf Code = 2 Then
buf = Mid(Cells(Row1, 5).Value, i, 10)
If buf Like "##########" Then
Bangou = buf
Exit For
End If
End If
Next
Return
番号書き出し:
With Sheets("証券番号")
For Row2 = 1 To 1000
If .Cells(Row2, 1) = "" Then
.Cells(Row2, 1) = Bangou
Bangou = ""
End If
Next
End With
Return
End Sub
▼
Sub 番号検出Type2() 'buf を文字列型に変更
Dim Row1&, Row2&, i&, Code As Long
Dim Bangou As String
Dim buf As String
Dim t As Single
t = Timer
Application.ScreenUpdating = False
With Sheets("証券番号").Columns("A")
.ClearContents
.NumberFormat = "@"
End With
For Row1 = 2 To 1000
ThisWorkbook.Sheets("元データ").Activate
If Cells(Row1, 5).Value Like "*[A-Z][A-Z]#######*" Then
Code = 1
GoSub 文字列切り出し
GoSub 番号書き出し
ElseIf Cells(Row1, 5).Value Like "*##########*" Then
Code = 2
GoSub 文字列切り出し
GoSub 番号書き出し
End If
Next
Application.ScreenUpdating = True
Debug.Print "Type2 "; Timer - t
MsgBox ("番号の書き出しが終わりました") ' Type2 25.1757
Exit Sub
文字列切り出し:
For i = 1 To Len(Cells(Row1, 5).Value)
If Code = 1 Then
buf = Mid(Cells(Row1, 5).Value, i, 9)
If buf Like "[A-Z][A-Z]#######" Then
Bangou = buf
Exit For
End If
ElseIf Code = 2 Then
buf = Mid(Cells(Row1, 5).Value, i, 10)
If buf Like "##########" Then
Bangou = buf
Exit For
End If
End If
Next
Return
番号書き出し:
With Sheets("証券番号")
For Row2 = 1 To 1000
If .Cells(Row2, 1) = "" Then
.Cells(Row2, 1) = Bangou
Bangou = ""
End If
Next
End With
Return
End Sub
▼'ここで処理時間に最も影響していると思われるのは、
'書き出し過程なので 書き出し方法を修正する
Row2 = Row2 + 1 で書き出し行がすぐ計算できる
Sub 番号検出Type3()
Const Level = 3
Dim Row1&, Row2&, i&, Code As Long
（中略）
Application.ScreenUpdating = True
ThisWorkbook.Sheets("証券番号").Activate
Debug.Print "Type"; Level; Timer - t
MsgBox ("番号の書き出しが終わりました") 'Type 3 0.46875
'Type 3 0.4726563
'Type 3 0.1640625
Exit Sub
（中略）
番号書き出し:
Row2 = Row2 + 1
Sheets("証券番号").Cells(Row2, 1) = Bangou
Bangou = ""
Return
End Sub
▼'書き出し先「証券番号」 最下行に追加する方式に変更
Sub 番号検出Type4()
Const Level = 4
（中略）
Application.ScreenUpdating = True
ThisWorkbook.Sheets("証券番号").Activate
Debug.Print "Type"; Level; Timer - t
MsgBox ("番号の書き出しが終わりました") 'Type 4 0.2460938
'Type 4 0.2070313
Exit Sub
文字列切り出し:
（略）
Return
番号書き出し:
Row2 = Row2 + 1
Sheets("証券番号").Cells(Row2, 1) = Bangou
Bangou = ""
Return
End Sub
▼元データを配列に格納、配列内で書き換え、
'あとでまとめて書き出す
Sub 番号検出Type5()
Const Level = 5
Dim Row1&, Row2&, i&, Code As Long
Dim buf As Variant
Dim ss As String, Bangou As String
Dim t As Single
t = Timer
'E列データを 配列buf に格納
buf = ThisWorkbook.Sheets("元データ").Range("E2:E1000").Value
For Row1 = 1 To UBound(buf)
ss = buf(Row1, 1)
If ss Like "*[A-Z][A-Z]#######*" Then
GoSub 文字列切り出し1
Row2 = Row2 + 1
buf(Row2, 1) = Bangou
ElseIf ss Like "*##########*" Then
GoSub 文字列切り出し2
Row2 = Row2 + 1
buf(Row2, 1) = Bangou
End If
Next
Application.Goto Sheets("証券番号").Range("A65536").End(xlUp).Offset(2)
With Selection
.Resize(Row2).Value = buf
.Activate
End With
Debug.Print "Type"; Level; Timer - t
MsgBox ("番号の書き出しが終わりました") '★Type 5 0.015625
'★Type 5 0.011718
Exit Sub
文字列切り出し1:
For i = 1 To Len(ss)
Bangou = Mid(ss, i, 9)
If Bangou Like "[A-Z][A-Z]#######" Then
Exit For
End If
Next
Return
文字列切り出し2:
For i = 1 To Len(ss)
Bangou = Mid(ss, i, 10)
If Bangou Like "##########" Then
Exit For
End If
Next
Return
End Sub
|
|
kanabun
- 08/8/7(木) 11:08 -
