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

質問

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

お礼

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

回答No.2

imogasi

丸投げの質問だが、一応コードの一例を書いておく。
ーー
例データ
取引先名 取引内容 金額
取引先1 ○○○ 1000
取引先1 ○○○ 2000
取引先2 ○○○ 3000
取引先2 ○○○ 4000
取引先2 ○○○ 5000
取引先3 ○○○ 6000
取引先3 ○○○ 7000
取引先5 ○○○ 8000
取引先6 ○○○ 9000
取引先6 ○○○ 10000
ーー
取引先が変わったら１シート追加し、順次下行に貼り付ける。
ーーー
コード
Sub test01()
d = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
MsgBox d
m = Worksheets("Sheet1").Cells(2, "A")
sn = Worksheets.Add.Index
Sheets(sn).Name = m
Sheets(sn).Range("A1:C1") = Array("取引先名", "取引内容", "金額")
K = 2 'コピー先の行番号
'--
For i = 2 To d '元シートデータで２行目以下繰り返し
If Worksheets("Sheet1").Cells(i, "A") = m Then '元シートで１行前と取引先が同じなら
Worksheets("Sheet1").Range("A" & i & ":J" & i).Copy Worksheets(sn).Cells(K, "A")
K = K + 1 '次回貼り付け先を１行下へ
Else
sn = Worksheets.Add.Index 'シートを増やし、インデックス番号取得
Sheets(sn).Range("A1:C1") = Array("取引先名", "取引内容", "金額") '見出しを第１行に
K = 2 '第２行目に下記で貼り付け
Worksheets("Sheet1").Range("A" & i & ":J" & i).Copy Worksheets(sn).Cells(K, "A")
K = K + 1
m = Worksheets("Sheet1").Cells(i, "A") '直前取引先を今の取引先にする
Sheets(sn).Name = m
End If
Next i
End Sub
上記例でテスト済み。
ーーー
実際では、変更箇所
Ｓｈｅｅｔ１
Range("A" & i & ":J" & i）のＪ－＞上記はデータがＪ列まで、の意味です。テストデータは３列しかないが、多めにしたもの。
Array("取引先名", ・・－＞実際の項目名で、実際の数だけ、””で囲って追加
Sheets(sn).Range("A1:C1") も項目数にあわせて変える。
ーー
スキルを要する２、３のことを使っている。この処理ロジックも含め、質問者には難しいかもしれないが、当面鵜呑みしかない。

お礼

親切に回答いただきましてありがとうございます。
この方法でやってみましたが、取引先ごとにシートを追加するのではなく、取引先ごとにファイルを作成したいのです。
他の方法を教えいただき無事解決することができましたが、いろいろなやり方があることがわかり大変勉強になりました。