Excel VBA質問箱 IV

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

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


24771 / 76732 ←次へ | 前へ→

【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
3 hits

【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 発言

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