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://okwave.jp/qa/q4361389.html
早速、mitarashiさんのマクロを使用し、ファイルの分割はできたのですが、
3列目までしか記載されておらず（これは当然のことだと思うのですが）
どこを変えればいいか、試行錯誤したのですがエラーになってしまいます。
残りの列の値も出力させるには、どうしたらよいでしょうか。

回答No.3

imogasi

私は、質問者が参考にしたいというコードはＦＳＯ（Ｇｏｏgleで参照）を含んでいて、初心者には難しすぎるのではないかと思う。
其れでソート法を提案する。
XXXX..aブックのＳｈｅｅｔ３で
場所列でソートする。すると
データ例
場所 資産番号 資産の種類 使用者 購入日
本社 123456 AA 東京太郎 2001/4/4
本社 123457 AA1 東京次朗 2001/4/5
本社 123458 AA2 東京三郎 2001/4/6
本社 123459 AA3 東京四郎 2001/4/7
本社 123460 AA4 東京五朗 2001/4/8
大阪 123457 BB 大阪花子 2003/1/10
大阪 123457 BB1 大阪菊子 2003/1/11
大阪 123457 BB2 大阪桃子 2003/1/12
大阪 123457 BB3 大阪華子 2003/1/13
大阪 123457 BB4 大阪梨子 2003/1/14
福岡 123458 AA 福岡一郎 2005/3/10
福岡 123458 AAC 福岡鳥郎 2005/3/11
福岡 123458 AAC 福岡川郎 2005/3/12
福岡 123458 AAC 福岡夏郎 2005/3/13
京都 123459 CC 京都次郎 2006/8/1
京都 123459 CC1 京都権二郎 2006/8/2
京都 123459 CC2 京都茂郎 2006/8/3
京都 123459 CC3 京都次郎 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」ブックのＳｈｅｅｔ１は
場所 資産番号 資産の種類 使用者 購入日
京都 123459 CC 京都次郎 2006/8/1
京都 123459 CC1 京都権二郎 2006/8/2
京都 123459 CC2 京都茂郎 2006/8/3
京都 123459 CC3 京都次郎 2006/8/

回答No.2

Wendy02

書いた方を差し置いて書くのは僭越ですが、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

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