Excelファイルをマクロでファイルに分割したい

資産管理のため、次のような作業を行いたいのですが、
勉強が足りず困っております。
あまえた質問で申し訳ないのですが、どうぞお知恵を貸してください。

下のようなExcelファイル（約3000行15列のもの）を

場所　資産番号　資産の種類　使用者　購入日・・・
本社　123456　AA　東京太郎　2001/4/4
大阪　123457　BB　大阪花子　2003/1/10
福岡　123458　AA　福岡一郎　2005/3/10
京都　123459　CC 京都次郎 2006/8/1　
　　　　　
場所ごとに分割して「場所」名のファイルを作成したいと思い、
過去の記事を探して、ここへたどり着きました。
http://oshiete.goo.ne.jp/qa/4361389.html
早速、mitarashiさんのマクロを使用し、ファイルの分割はできたのですが、
3列目までしか記載されておらず（これは当然のことだと思うのですが）
どこを変えればいいか、試行錯誤したのですがエラーになってしまいます。
残りの列の値も出力させるには、どうしたらよいでしょうか。

No.3 回答者： imogasi 回答日時： 2011/01/23 20:58

私は、質問者が参考にしたいというコードはＦＳＯ（Ｇｏｏgleで参照）を含んでいて、初心者には難しすぎるのではないかと思う。

其れでソート法を提案する。
XXXX..aブックのＳｈｅｅｔ３で
場所列でソートする。すると
データ例
場所資産番号資産の種類使用者購入日
本社123456AA東京太郎2001/4/4
本社123457AA1東京次朗2001/4/5
本社123458AA2東京三郎2001/4/6
本社123459AA3東京四郎2001/4/7
本社123460AA4東京五朗2001/4/8
大阪123457BB大阪花子2003/1/10
大阪123457BB1大阪菊子2003/1/11
大阪123457BB2大阪桃子2003/1/12
大阪123457BB3大阪華子2003/1/13
大阪123457BB4大阪梨子2003/1/14
福岡123458AA福岡一郎2005/3/10
福岡123458AAC福岡鳥郎2005/3/11
福岡123458AAC福岡川郎2005/3/12
福岡123458AAC福岡夏郎2005/3/13
京都123459CC 京都次郎 2006/8/1
京都123459CC1京都権二郎 2006/8/2
京都123459CC2京都茂郎 2006/8/3
京都123459CC3京都次郎 2006/8/4
コード
標準モジュールに
Sub Macro3()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim midasi
Set sh1 = Workbooks("xxxx.xls").Worksheets("Sheet3")
d = sh1.Range("a65536").End(xlUp).Row
MsgBox d
r = sh1.Range("IV2").End(xlToLeft).Column
MsgBox r
midasi = sh1.Range(sh1.Cells(1, "A"), Cells(1, r))
'--初期設定
mae = sh1.Cells(2, "A") '最初データ行の場所
hajime = 2 '第２行
basho = sh1.Cells(2, "A") '最初の場所
'--最終行までくり返し
For i = 3 To d
If sh1.Cells(i, "A") = mae Then '直前行と場所が変わったか
Else
owari = i - 1
'---
Workbooks.Add.Activate '新規ブックを開く
Set sh2 = ActiveWorkbook.Worksheets("Sheet1")
sh2.Range(sh2.Cells(1, "A"), sh2.Cells(1, r)) = midasi
sh1.Range(sh1.Cells(hajime, 1), sh1.Cells(owari, r)).Copy sh2.Range("A2")
MsgBox basho
ActiveWorkbook.SaveAs basho & ".xls"
ActiveWorkbook.Close
'---初期設定入れ替え
mae = sh1.Cells(i, "A")
hajime = i
basho = sh1.Cells(i, "A")
End If
Next i
'--最後の場所の処理
owari = i - 1
Workbooks.Add.Activate '新規ブックを開く
Set sh2 = ActiveWorkbook.Worksheets("Sheet1")
sh2.Range(sh2.Cells(1, "A"), sh2.Cells(1, r)) = midasi
sh1.Range(sh1.Cells(hajime, 1), sh1.Cells(owari, r)).Copy ActiveWorkbook.Worksheets("sheet1").Range("A2")
MsgBox basho
ActiveWorkbook.SaveAs basho & ".xls"
ActiveWorkbook.Close
End Sub
結果
例えば「京都.xls」ブックのＳｈｅｅｔ１は
場所資産番号資産の種類使用者購入日
京都123459CC 京都次郎 2006/8/1
京都123459CC1京都権二郎 2006/8/2
京都123459CC2京都茂郎 2006/8/3
京都123459CC3京都次郎 2006/8/

No.2 回答者： Wendy02 回答日時： 2011/01/22 12:09

書いた方を差し置いて書くのは僭越ですが、mitarashiさんの書いたコードを尊重すると、

col = sourceRange.Columns.Count　'※
と、列を取れば、自動的に取れますが、定数で、列数を入れても以下のようにしても可能です。
col = 5

VBAとして、ベテランの人のコードだと思います。（こういう言い方は、返って失礼かもしれませんが。）

'//
Sub testR()
　　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
　　Dim col As Long　'※
　　Set sourceRange = ActiveSheet.Range("A1").CurrentRegion
　　Set fieldNameRange = sourceRange.Rows(1)
　　col = sourceRange.Columns.Count　'※
　　
　　Set sourceRange = sourceRange.Offset(1, 0).Resize(sourceRange.Rows.Count - 1, col)　''※
　　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, col) '※
　　　　　　Else
　　　　　　　　Set myDic.Item(.Value) = Union(myDic.Item(.Value), targetRange.Resize(1, col))　'※
　　　　　　End If
　　　　End With
　　Next i

'--省略---

No.1 回答者： keithin 回答日時： 2011/01/22 10:51

A1セルに「場所」と書いてあってA2（２行目）以下から実データが並んでいるとして。

たとえばこんな具合に。

Sub sample()
　Dim s0 As Worksheet
　Dim h
　Worksheets("元になるリストのシート名").Copy before:=Worksheets(1)
　Set s0 = Worksheets(1)

　Do Until Application.CountA(s0.Range("A:A")) < 2
　　h = s0.Range("A2").Value
　　s0.Range("A1").AutoFilter field:=1, Criteria1:=h
　　With Worksheets.Add
　　　s0.AutoFilter.Range.Copy Destination:=.Range("A1")
　　　.Name = h
　　　.Move
　　　ActiveWorkbook.SaveAs Filename:="C:\保存先フォルダ名\" & h & ".xls"
　　　ActiveWorkbook.Close False
　　　s0.AutoFilter.Range.Offset(1).Delete shift:=xlShiftUp
　　End With
　Loop

　Application.DisplayAlerts = False
　s0.Delete

End Sub