エクセルファイルを取引先ごとに分割

質問

1つのエクセルファイルにすべての取引先の情報が入っているファイルが存在するのですが、そのファイルを取引先ごとに自動で分割したいと思っています。
データの並びは以下のようなものです。
Ａ列　　Ｂ列　　Ｃ列
取引先名　取引内容　金額
取引先1　　○○○　　1000
取引先1　　○○○　　1000
取引先2　　○○○　　1000
取引先2　　○○○　　1000
ネットでいろいろ検索し下記までは見つけて実施してみたのですが、このままですと分割したファイルに表題（各列の1行目の部分）をつけることができません。
http://soudan1.biglobe.ne.jp/qa4088700.html
分割したファイルのすべてに表題をつけたいと思い上記の内容を変更してやってみましたが今の自分の力ではうまくいきません。
申し訳ありませんが、表題部をつけてファイルを分割する方法をアドバイスいただけないでしょうか
宜しくお願いいたします。

回答No.1

mitarashi · ベストアンサー

元の質問の回答者です。ご質問の様にソーティングされたデータであれば、もっと分かりやすい、VBAの基本的な機能でのコード作成が可能だと思いますが、それは他の回答者にお任せします。
とりあえず、以前回答したコードを、見出し行を全ファイルに入れる様、改造したコードを呈示いたします。
Sub test()
Dim sourceRange As Range
Dim targetRange As Range
Dim fieldNameRange As Range
Dim myDic As Object
Dim i As Long, j As Long
Dim myKey As Variant

Set sourceRange = ActiveSheet.Range("A1").CurrentRegion
Set fieldNameRange = sourceRange.Rows(1)
Set sourceRange = sourceRange.Offset(1, 0).Resize(sourceRange.Rows.Count - 1, sourceRange.Columns.Count)
Set myDic = CreateObject("Scripting.Dictionary")
For i = 1 To sourceRange.Rows.Count
Set targetRange = sourceRange.Cells(i, 1)
With targetRange
If Not myDic.exists(.Value) Then
myDic.Add .Value, targetRange.Resize(1, 3)
Else
Set myDic.Item(.Value) = Union(myDic.Item(.Value), targetRange.Resize(1, 3))
End If
End With
Next i
myKey = myDic.keys
For i = 0 To myDic.Count - 1
Call saveToText(myDic.Item(myKey(i)), fieldNameRange)
Next i
Set myDic = Nothing
End Sub

Private Sub saveToText(targetRange As Range, fieldNameRange As Range)
Dim fso As Object
Dim filePath As String
Dim i As Long
Dim oneLine As String
Dim area As Range

filePath = ThisWorkbook.Path & "\" & targetRange.Cells(1).Value & ".txt"
Set fso = CreateObject("Scripting.FileSystemObject")
With fso.CreateTextFile(filePath)
.writeline myJoin(fieldNameRange)
For Each area In targetRange.Areas
For i = 1 To area.Rows.Count
.writeline myJoin(area.Rows(i))
Next i
Next area
.Close
End With
Set fso = Nothing
End Sub

Private Function myJoin(target As Range) As String
Dim i As Long
Dim buf() As Variant

ReDim buf(1 To target.Cells.Count)
For i = 1 To target.Cells.Count
buf(i) = target.Cells(i).Value
Next i
myJoin = Join(buf, vbTab)
End Function

お礼

回答ありがとうございます。
回答いただいた内容で問題なくできました。
本当にありがとうございました。