Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


4322 / 13644 ツリー ←次へ | 前へ→

【57294】セル内の条件に合う文字列のみを抽出したい わんころもち 08/8/5(火) 13:48 質問[未読]
【57297】Re:セル内の条件に合う文字列のみを抽出し... ハチ 08/8/5(火) 15:47 発言[未読]
【57308】Re:セル内の条件に合う文字列のみを抽出し... わんころもち 08/8/6(水) 9:24 お礼[未読]
【57309】Re:セル内の条件に合う文字列のみを抽出し... ハチ 08/8/6(水) 10:07 発言[未読]
【57315】Re:セル内の条件に合う文字列のみを抽出し... わんころもち 08/8/6(水) 18:04 発言[未読]
【57317】Re:セル内の条件に合う文字列のみを抽出し... kanabun 08/8/7(木) 11:08 発言[未読]

【57294】セル内の条件に合う文字列のみを抽出した...
質問  わんころもち  - 08/8/5(火) 13:48 -

引用なし
パスワード
   いつもお世話になっております。
データの分析を行なうにあたり、以下のようなところで躓いてしまいました。
もしよろしければ、どなたかご教示いただけますでしょうか。

元のシートのE2セルからE1000セルまでの範囲には、任意の文章が入力されています。
その中に、10桁の半角数字やアルファベット2桁+7桁の半角数字があった場合、
その部分だけを「Sheet2」のA列にひとつずつ書き出していきたいと考えています。

If Like構文でそれぞれのセルに該当する文字列が含まれているかどうかのチェックは出来るのですが、
該当する部分だけを変数に格納する方法がわからずに難儀しております。

プログラムそのものでなくても、このコマンドで大丈夫、といった形でも結構ですので、
どうかご教導いただけますでしょうか。

【57297】Re:セル内の条件に合う文字列のみを抽出...
発言  ハチ  - 08/8/5(火) 15:47 -

引用なし
パスワード
   ▼わんころもち さん:
>>If Like構文でそれぞれのセルに該当する文字列が含まれているかどうかのチェックは出来るのですが、
>該当する部分だけを変数に格納する方法がわからずに難儀しております。

この部分ができるのであれば、
対象のセルに対してMidで1文字づつズラしながら、
文字列を切り出していってはどうでしょうか?
文字数によっては重たい処理になりますので、もっと良い案があるかも。

'例)アルファベット1文字+数字1文字を抜き出す
Sub Test()
  Dim i As Long
  Dim buf As Variant
  
  With ActiveCell
    For i = 1 To Len(.Value)
      buf = Mid(.Value, i, 2)
      If buf Like "[A-Z]#" Then
        MsgBox buf
      End If
    Next
  End With

End Sub

【57308】Re:セル内の条件に合う文字列のみを抽出...
お礼  わんころもち  - 08/8/6(水) 9:24 -

引用なし
パスワード
   ▼ハチ さん:

ご教示有難うございました。
参考にさせていただき、以下のコードで無事に目的を達成できました。
力技ですが、1000行で30秒ほどで終わりましたので、自分的にはよしとします。

Sub 番号検出()

Dim Row, Row2, i, Code As Long
Dim Bangou As String
Dim buf As Variant
  
Application.ScreenUpdating = False

For Row = 2 To 1000
  ThisWorkbook.Sheets("元データ").Activate
  If Cells(Row, 5).Value Like "*[A-Z][A-Z]#######*" Then
    Code = 1
    GoSub 文字列切り出し
    GoSub 番号書き出し
  ElseIf Cells(Row, 5).Value Like "*##########*" Then
    Code = 2
    GoSub 文字列切り出し
    GoSub 番号書き出し
  End If

Next

MsgBox ("番号の書き出しが終わりました")
Application.ScreenUpdating = True

Exit Sub

文字列切り出し:

  For i = 1 To Len(Cells(Row, 5).Value)
     
    If Code = 1 Then
      buf = Mid(Cells(Row, 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(Row, 5).Value, i, 10)
      If buf Like "##########" Then
        Bangou = buf
        Exit For
      End If
    End If
  Next
Return

番号書き出し:
ThisWorkbook.Sheets("Sheet2").Activate
  For Row2 = 1 To 1000
    If Cells(Row2, 1) = "" Then
      Cells(Row2, 1) = Bangou
      Bangou = ""
    End If
  Next
Return

End Sub

【57309】Re:セル内の条件に合う文字列のみを抽出...
発言  ハチ  - 08/8/6(水) 10:07 -

引用なし
パスワード
   ▼わんころもち さん:
>力技ですが、1000行で30秒ほどで終わりましたので、自分的にはよしとします。

解決済みとなってますので、参考という程度で見てください。

>    GoSub 文字列切り出し
>    GoSub 番号書き出し

GoSubはあまり、使いません。
Private Sub 文字切り出し(ByVal Code As Long)

など、別プロシジャにするのが一般的です。
好みの問題もありますので、参考ということで。

文字の切り出しの部分ですが、
自分の書いたロジックには無駄がありますね・・・
'例)3文字を切り出す
Sub test()
  Dim str As String
  Dim i As Long
  Dim buf As Variant
  
  str = "あいうえお"
  For i = 1 To Len(str) 'ここに補正値 -2 を追加する
    buf = Mid(str, i, 3)
    If Len(buf) = 3 Then
      MsgBox buf
    Else
      MsgBox "無駄:" & buf
    End If
  Next
End Sub

>番号書き出し:
>ThisWorkbook.Sheets("Sheet2").Activate
>  For Row2 = 1 To 1000
>    If Cells(Row2, 1) = "" Then
>      Cells(Row2, 1) = Bangou
>      Bangou = ""

    ここにExit For があると、
    少し無駄ループが減るのでは?

>    End If
>  Next
>Return

最終行に値と追加するロジックは、
もっと効率的なサンプルがあると思います。
探してみてください。

【57315】Re:セル内の条件に合う文字列のみを抽出...
発言  わんころもち  - 08/8/6(水) 18:04 -

引用なし
パスワード
   ▼ハチ さん:

重ね重ねご助言有難うございます。

最終行にデータを追加するサブルーチンを改良してみました。
これで変なループがなくなるので、多少改善したと思っています。

番号書き出し:

ThisWorkbook.Sheets("証券番号").Activate
  lngLine = Range("A65536").End(xlUp).Row
  Cells(lngLine + 1, 1) = Bangou
  Bangou = ""
Return

【57317】Re:セル内の条件に合う文字列のみを抽出...
発言  kanabun  - 08/8/7(木) 11:08 -

引用なし
パスワード
   ▼わんころもち さん:

おじゃまします。
>力技ですが、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

4322 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free