VBAで文字列を抜き出す

質問

添付画像左のデータベースを基にシートを追加して、そのシートに添付画像右のような結果をVBAで求めたいです。
ご教授宜しくお願い致します。

回答No.3

keithin · ベストアンサー

作成中にちょっと誤記がありました。失礼しました。

sub macro1()
　dim a as variant
　dim h as range
　dim r as long
　dim w0 as worksheet

　set w0 = activesheet
　worksheets.add after:=w0
　r = 1
　range("A1:G1") = array("苗字","名前","住所","TEL","〒","好きなスポーツ","性別")

　on error resume next
　for each h in w0.range("A1:A" & w0.range("A65536").end(xlup).row)
　　if h <> "" then
　　　a = split(replace(application.trim(replace(replace(h, "　"," "),"：",":")),": ",":"), " ")
　　　r = r + 1
　　　cells(r, "A") = split(a(0), ":")(1)
　　　cells(r, "B") = split(a(1), ":")(1)
　　　cells(r, "C") = split(a(2), ":")(1)
　　　cells(r, "D") = split(a(3), ":")(1)
　　　cells(r, "E") = split(a(4), ":")(1)
　　　cells(r, "F") = a(5)
　　　cells(r, "G") = a(6)
　　end if
　next
end sub

お礼

出来ました!!
ありがとうございますm(_ _)m

回答No.2

kagakusuki

元データのどの行のセルにおいても、名字、名前、住所、TEL、〒、好きなスポーツ、性別の全項目が入力されていて、途中に一部のデータが抜けているセルは存在しないという場合には、[区切り位置]機能を利用した次の様なマクロにされては如何でしょうか。

Sub QNo9044546_VBAで文字列を抜き出す()

Dim OrigSheet As Worksheet, NewSheet As Worksheet, _
FirstCell As Range, myHeight As Long

With Cells(Rows.Count, 1).End(xlUp)
Set FirstCell = Cells(1, 1).Resize(.Row). _
Find(What:="名字:* 名前:* 住所:* TEL:* 〒:* * *", After:=Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, MatchByte:=False, SearchFormat:=False)
If FirstCell Is Nothing Then
MsgBox "処理すべきデータがありません。" & _
vbCrLf & "マクロを終了します。", _
vbExclamation, "データ無し"
GoTo labelE
End If
myHeight = .Row - FirstCell.Row + 1
End With

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

Set OrigSheet = ActiveSheet
Sheets.Add After:=OrigSheet
Set NewSheet = ActiveSheet
With NewSheet
Cells(2, 1).Resize(myHeight).Value = FirstCell.Resize(myHeight).Value
With .Cells(1, 1)
.Value = "名字 名前 住所 TEL 〒 好きなスポーツ 性別"
With .Resize(myHeight + 1, 1)
.Replace What:="名字:", Replacement:="", ReplaceFormat:=False
.Replace What:=" *?:", Replacement:=" "
.TextToColumns DataType:=xlGeneralFormat, ConsecutiveDelimiter:=True, _
Tab:=False, Semicolon:=False, Comma:=False, Space:=True, Other:=False
End With
End With
With .UsedRange
With .Borders
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
.Columns.AutoFit
.Resize(1).HorizontalAlignment = xlCenter
End With
End With

labelE:
Selection.Replace What:="", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False

With Application
.Calculation = xlAutomatic
.ScreenUpdating = False
End With

End Sub

回答No.1

keithin

sub macro1()
　dim a as variant
　dim h as range
　dim r as long
　dim w0 as worksheet

　set w0 = activesheet
　worksheets.add after:=w0
　r = 1
　range("A1:G1") = array("苗字","名前","住所","TEL","〒","好きなスポーツ","性別")

　on error resume next
　for each h in w.range("A1:A" & w.range("A65536").end(xlup).row)
　　if h <> "" then
　　　a = split(application.trim(replace(replace(h, "　"," "),"：",":")), " ")
　　　r = r + 1
　　　cells(r, "A") = split(a(0), ":")(1)
　　　cells(r, "B") = split(a(1), ":")(1)
　　　cells(r, "C") = split(a(2), ":")(1)
　　　cells(r, "D") = split(a(3), ":")(1)
　　　cells(r, "E") = split(a(4), ":")(1)
　　　cells(r, "F") = a(5)
　　　cells(r, "G") = a(6)
　　end if
　next
end sub

補足

早速の回答ありがとうございます！
構文をコピーして実行してみたのですが、新しく追加されたシートのA1からG1に名字～性別が入力されただけになりました。（構文10行目までしか反応していない？）
現在、使用しているパソコンのエクセルが２００３なので、それが影響しているのでしょうか？