エクセルマクロでのテキスト振り分け

質問

エクセルのマクロを利用してテキストファイルのデータを振り分けてブックを作成したいのですが、テキストデータは下記の内容になります。
番号,名前,都道府県
0001,あああ,北海道
0002,いいい,東京都
0003,ううう,大阪府
↓
2998,わわわ,奈良県
2999,ををを,石川県
3000,んんん,福岡県

このテキストデータを都道府県名別にブックを作成して、都道府県名.xls(北海道.xls、青森県.xls ・・・沖縄県.xls)の名前で保存したいのでよろしくお願いいたします。

回答No.1

Wendy02 · ベストアンサー

こんばんは。

以下のように作ってみました。ちょっと試してみてください。同名ブックがある時は、そのブックを開いて上書きされます。

終了前に、テンポラリーブック（並び替えに使ったブック）の保存を聞いてきます。保存の時にエラーがあると、エラーメッセージが出て、終了メッセージが出ます。

Option Explicit
Dim msg As String, msgno As Integer
Sub TextDevide2Xls()
Dim Fname As String, FNo As Integer, TextLine As String
Dim i As Long, myArray As Variant
　Fname = Application.GetOpenFilename("Txt ファイル(*.txt),*.txt")
　If Fname = "False" Then
　　Exit Sub
　End If
Workbooks.Add
Application.ScreenUpdating = False
FNo = FreeFile()
Open Fname For Input As #FNo
　　Do While Not EOF(1)
　　　　Line Input #FNo, TextLine
　　　　i = i + 1
　　　　 myArray = Split(TextLine, ",")
　　　　 With Cells(i, 1).Resize(, UBound(myArray) + 1)
　　　　　　.NumberFormatLocal = "@"
　　　　　　.Value = myArray
　　　　 End With
　　Loop
Close #FNo
With Range("A1").CurrentRegion
　　.Sort Key1:=Range("C2"), Order1:=xlAscending, _
　　　　　Key2:=Range("A2"), Order2:=xlAscending, _
　　　　　Header:=xlYes, _
　　　　　Orientation:=xlTopToBottom
End With
Application.ScreenUpdating = True
'ユニーク振り分け
Call Xl2NewBk
If Err.Number > 0 Then
　　msg = "異常"
　　msgno = 16
End If
MsgBox msg & "終了", msgno
If MsgBox("テンポリラーブックを廃棄しますか？", 32 + vbOKCancel) = vbOK Then
　 ActiveWorkbook.Close False
　 If msg <> "" Then ActiveWorkbook.Close False
End If
msg = "": msgno = 0
End Sub
Private Sub Xl2NewBk()
Dim myHead As Variant
Dim i As Long, j As Long, r As String
Dim r1 As Long, r2 As Long
　myHead = Range("A1", Range("IV1").End(xlToLeft)).Value
　Application.ScreenUpdating = False
　With Range("A2", Range("A2").End(xlDown)). _
　　　　　　　　　　　　　　　 Resize(, UBound(myHead, 2))
　　i = 1: j = 1
　　Do
　　　Do
　　　　r = .Cells(j, 3).Value
　　　　j = j + 1
　　　Loop While r = .Cells(j, 3).Value
　　　r1 = i
　　　r2 = j - 1
　　　'処理
　　　.Rows(r1 & ":" & r2).Copy
　　　Workbooks.Add
　　　With ActiveWorkbook
　　　.ActiveSheet.Range("A1").Resize(, UBound(myHead, 2)).Value = _
　　　myHead
　　　.ActiveSheet.Range("A2").PasteSpecial
　　　On Error GoTo ErrHandler
　　　Application.DisplayAlerts = False
　　　　.SaveAs r
　　　Application.DisplayAlerts = True
　　　.Close
　　　End With
　　　i = j
　　　j = j
　　Loop Until i > .Rows.Count
　End With
　Application.ScreenUpdating = True
　Exit Sub
ErrHandler:
　MsgBox "Err:" & Err.Number & Chr(13) & _
　　　　Err.Description
　msg = "異常"
　msgno = 16
End Sub