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