店舗名（任意の単語）を基準にデータをリスト化していく方法

質問

店舗名（任意の単語）を基準にデータをリスト化していく方法

前回ご質問させて頂いた内容の続きになります。

一度にに質問するとタイトルが分かりにくくなるので、分けて質問させて頂きました。

はじめに表(1)の様に、Ａ～Ｄの内容を店舗名で振り分けて、それぞれの店舗欄の一番下の空欄に追加するマクロを考えております。
　（○○店はＥ～Ｇ　□□店はＨ～Ｊ）

なお、表(2)のように翌営業日には、前日分は存在しなくなります。
　（Ａ～Ｄには毎回、当日分のデータが表示されます。）

こちらも全くのお手上げ状態で大変困っております。

どなたか、教えていただけないでしょうか？

よろしくお願い致します。

使用環境：Windows7x64 Office 2007

～ここから表(1)～

2010年9月17日分
　　　Ａ　　　　　　　Ｂ　　　　Ｃ　　　Ｄ

１　　2010/09/17　　○○店　　△△　　１０００円

２　　2010/09/17　　□□店　　☆☆　　２０００円

３　　2010/09/17　　○○店　　◆◆　　３０００円

　　　・　　　　　　　・　　　　・　　　　・
　　　・　　　　　　　・　　　　・　　　　・
　　　・　　　　　　　・　　　　・　　　　・

　　　Ｅ　　　　　　Ｆ　　　　Ｇ　　　　　　Ｈ　　　　　　Ｉ　　　　Ｊ
１　　○○店　　　　　　　　　　　　　　　　□□店

２　　日付　　　　　取引先　　金額　　　　　日付　　　　　取引先　　金額

３　　2010/09/17　△△　　１０００円　　2010/09/17　☆☆ 　　２０００円

４　　2010/09/17　◆◆　　３０００円

～ここまで表(1)～

～ここから表(2)～
2010年9月18日分
　　　Ａ　　　　　　　Ｂ　　　　Ｃ　　　Ｄ

１　　2010/09/18　　○○店　　■■　　４０００円

２　　2010/09/18　　□□店　　●●　　５０００円

３　　2010/09/18　　○○店　　◆◆　　６０００円

４　　2010/09/18　　□□店　　★★　　７０００円

　　　・　　　　　　　・　　　　・　　　　・
　　　・　　　　　　　・　　　　・　　　　・
　　　・　　　　　　　・　　　　・　　　　・

　　　Ｅ　　　　　　Ｆ　　　　Ｇ　　　　　　Ｈ　　　　　　Ｉ　　　　Ｊ
１　　○○店　　　　　　　　　　　　　　　　□□店

２　　日付　　　　　取引先　　金額　　　　　日付　　　　　取引先　　金額

３　　2010/09/17　△△　　１０００円　　2010/09/17　☆☆ 　　２０００円

４　　2010/09/17　◆◆　　３０００円　　2010/09/18　●●　　 ５０００円

５　　2010/09/18　■■　　４０００円　　2010/09/18　★★　　 ７０００円

６　　2010/09/18　◆◆　　６０００円
～ここまで表(2)～

回答No.3

Wendy02 · ベストアンサー

シートに一回きりで、シードを変えていくものだと解釈していました。
直しましたので、以下で試してみてください。

Sub SeparateShopsDataR()
　Dim Ar() As Variant
　Dim i As Long, j As Long, k As Long, x As Long
　Dim v As Variant, n As Range
　With ActiveSheet
　　'シートチェック
　If .Cells(1, Columns.Count).End(xlToLeft).Column < 4 Then
　　MsgBox "予想しないシートのようです。", vbExclamation
　　Exit Sub
　End If

　Application.ScreenUpdating = False
　If IsDate(.Cells(1, 1).Text) Then
　　'タイトル行のあるなしの判定
　　.Cells(1, 1).EntireRow.Insert xlDown
　　.Cells(1, 1).Resize(, 4).Value = Array("aaa", "bbb", "ccc", "ddd")
　Else
　　MsgBox "1行目がデータではありません。", vbExclamation
　　Exit Sub
　End If
　If .FilterMode Then .ShowAllData
　With Range("B1", Cells(Rows.Count, 2).End(xlUp))
　　.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
　　For i = 2 To .Rows.Count
　　If .Cells(i, 1).EntireRow.Hidden = False Then
　　ReDim Preserve Ar(j)
　　Ar(j) = .Cells(i, 1).Value
　　j = j + 1
　　End If
　　Next
　End With
　If .FilterMode Then .ShowAllData '.ShowAllData 変更
　With .Range("A1").CurrentRegion.Resize(, 4)
　　For Each v In Ar()
　With ActiveSheet
　 k = WorksheetFunction.CountA(Range("E2", Cells(2, Columns.Count)))
　　Set n = .Range(.Cells(2, 5), .Cells(Rows.Count, .Columns.Count)) _
　　.Find(What:=v, LookAt:=xlPart)
　　If n Is Nothing Then
　　　If .Cells(2, 5 + (k * 3)).Value = "" Then
　　　　.Cells(2, 5 + (k * 3)).Value = v
　　　　.Cells(3, 5 + (k * 3)).Resize(, 3).Value = Array("日付", "取引先", "金額")
　　　End If
　　End If
　End With
　If Not n Is Nothing Then
　　x = Cells(Rows.Count, n.Column).End(xlUp).Row + 1
　End If
　.AutoFilter
　.AutoFilter Field:=2, Criteria1:=v
　.Columns(2).Hidden = True
　If n Is Nothing Then
　　.Range(.Cells(2, 1), .Cells(.Cells.Count)).Resize(, 4).Copy Cells(4, 5 + (k * 3))
　Else
　　.Range(.Cells(2, 1), .Cells(.Cells.Count)).Resize(, 4).Copy Cells(x, n.Column)
　End If
　.Columns(2).Hidden = False
　If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
　　Next
　End With
　　If .FilterMode Then .ShowAllData
　　.AutoFilterMode = False
　　.Rows(1).Delete
　　Application.ScreenUpdating = True
　End Sub

お礼

ご回答有り難うございます。

ご教授頂いた内容で実行しましたところ、コンパイルエラー End withが必要ですと表示されました。

どの部分にEnd withを追加すればよろしいでしょうか？

ご質問ばかりで申し訳御座いませんが、よろしくお願い致します！

補足

End with の場所がわかりました！

もっと自分で試す前にご返信してしまい申し訳御座いません！

この度は本当に有り難うございました！

明日改めて、理解できる部分から勉強し、応用してみたいと思います！

連休中にわざわざ私のご質問に最後までお付き合い頂き有り難うございました！

間違いなくベストアンサーです！本当に有り難うございました！

回答No.4

Wendy02

>ご教授頂いた内容で実行しましたところ、コンパイルエラー End withが必要で
>すと表示されました。

失礼しました。念のためにこちらのコメントを入れておきます。
アップロードするときに、文字制限(2000字）で、最後の部分が引っかかって、手でいれたために、文字が落ちてしまいました。

　　Application.ScreenUpdating = True
　End With　' ←ここを入れます。
End Sub

回答No.2

Wendy02

最近、同じような質問に回答したような気がします。コードを書く前にお聞きしようとは思いましたが、どうやら、A列に出てきた店名を、ひとつずつ選んで（一意）で、右側に並べることになるような気がしました。予め決められた店名の場合は、コードが変わります。また、元のデータにはタイトル行がないものとして処理されています。処理されたものには、タイトルが付きます。現在の方法では、金額が文字列になって扱われていますが、それを数字にして処理出来るようにしなくてはならないかもしれません。

今回は、必ず、標準モジュールに貼り付けてください。シートモジュールではありません。
理由は、どのシートにも同じマクロを実行しなければならないからです。
起動させる時は、Call を使うほうがよいです。
例：
Private Sub CommandButton2_Click()
　　Call SeparateShopsData
End Sub
'//
Sub SeparateShopsData()
　Dim Ar() As Variant
　Dim i As Long, j As Long, k As Long, m As Long
　Dim v As Variant
　With ActiveSheet
　　'シートチェック
　　If .Cells(1, Columns.Count).End(xlToLeft).Column > 4 Then
　　　MsgBox "既にマクロが実行されたようです。", vbExclamation
　　　Exit Sub
　　ElseIf .Cells(1, Columns.Count).End(xlToLeft).Column < 4 Then
　　　MsgBox "予想しないシートのようです。", vbExclamation
　　　Exit Sub
　　End If
　　Application.ScreenUpdating = False
　　If IsDate(.Cells(1, 1).Text) Then
　　　'タイトル行のあるなしの判定
　　　.Cells(1, 1).EntireRow.Insert xlDown
　　　.Cells(1, 1).Resize(, 4).Value = Array("aaa", "bbb", "ccc", "ddd")
　　　m = 1
　　End If
　　If .FilterMode Then .ShowAllData
　　With Range("B1", Cells(Rows.Count, 2).End(xlUp))
　　　.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
　　　For i = 2 To .Rows.Count
　　　　If .Cells(i, 1).EntireRow.Hidden = False Then
　　　　　ReDim Preserve Ar(j)
　　　　　Ar(j) = .Cells(i, 1).Value
　　　　　j = j + 1
　　　　End If
　　　Next
　　End With
　　.ShowAllData
　　With .Range("A1").CurrentRegion.Resize(, 4)
　　　For Each v In Ar()
　　　　ActiveSheet.Cells(2, 5 + (k * 3)).Value = v
　　　　ActiveSheet.Cells(3, 5 + (k * 3)).Resize(, 3).Value = Array("日付", "取引先", "金額")
　　　　.AutoFilter
　　　　.AutoFilter Field:=2, Criteria1:=v
　　　　.Columns(2).Hidden = True
　　　　.Range(.Cells(2, 1), .Cells(.Cells.Count)).Resize(, 4).Copy ActiveSheet.Cells(3 + m, 5 + (k * 3))
　　　　.Columns(2).Hidden = False
　　　　k = k + 1
　　　Next
　　End With
　　.ShowAllData
　　.AutoFilterMode = False
　　.Rows(1).Delete
　　Application.ScreenUpdating = True
　End With
End Sub

お礼

こんにちわ！

ご回答有り難うございます。

早速、マクロ（Module8）にご教授頂いた内容をコピーして貼り付けし、
シート８にボタンを設置しクリックしましたところ、Ａ～Ｄの内容を振り分けていないにも関わらず、

「既にマクロが実行されたようです。」と表示され振り分けができませんでした。

※標準モジュールはこのマクロで８個目になります。
※このマクロはこのシートでしか使いません。
※Ａ～Ｄは２列目から始めた方がよろしいでしょうか？

ご質問ばかりで申し訳御座いませんが、どうかご指導の方よろしくお願い致します！

補足

Ａ　　　　　　Ｂ　　Ｃ　　Ｄ
１　2010/9/17　○○店　△△　1000
２　2010/9/17　□□店　☆☆　2000
３　2010/9/17　○○店　◆◆　3000

Ａ～Ｄに上記の様に記入し、Ｅ列以降に何も入れずにマクロを実行した場合は、店舗ごとに振り分けが行われました！

ですが、ここで問題点(1)が生じます。
　　Ａ　　　　　　Ｂ　　Ｃ　　Ｄ
１　2010/9/17　○○店　△△　1000
２　2010/9/17　□□店　☆☆　2000

の様に店舗名が重複していない場合は、実行時エラー1004　WorksheetクラスのShowAllDataメソッドが失敗しましたと表示されます。

ここから問題点(2)です。
　　Ａ　　　　　　Ｂ　　Ｃ　　Ｄ
１　2010/9/17　○○店　△△　1000
２　2010/9/17　□□店　☆☆　2000
３　2010/9/17　○○店　◆◆　3000

と入力し、振り分けた後に、

　　Ａ　　　　　　Ｂ　　Ｃ　　Ｄ
１　2010/9/18　○○店　●●　1000　　　※日付が変わっています。　　

と入力し、実行したところ「既にマクロが実行されたようです。」

と表示されそれぞれの店舗欄の一番下に追加できませんでした。
　※上記の様に、その日にデータの無い店舗も御座います。

ご回答の最初の部分へのご回答です。

＞元のデータにはタイトル行がないものとして処理されています。
　見落としておりました。お礼に記載した内容は無いものとして下さい。申し訳御座いません。

＞予め決められた店名の場合は、コードが変わります。
　店名は決められておりません。（実際はここは個人名で随時変動するためです。）

＞金額が文字列になって扱われていますが、それを数字にして処理出来るようにしなくてはならないかもしれません。
　円を入力せずに処理しましたところ、問題御座いませんでした。

説明が下手で申し訳御座いませんが、どうぞよろしくお願い致します！

回答No.1

kagakusuki

適当な列を一列、作業列として使用する方法です。
　ここでは仮にZ列を作業列として使用するものとします。
　先ず、Z1セルに次の数式を入力して下さい。

=$B1&COUNTIF($B$1:$B1,$B1)

　次に、Z1セルをコピーして、Z2以下のセルに貼り付けて下さい。
　次に、F3セルに次の数式を入力して下さい。

=IF(ROWS($2:2)>COUNTIF($B:$B,E$1),"",INDEX($A:$D,MATCH(E$1&ROWS($2:2),$Z:$Z,0),3))

　次に、G3セルに次の数式を入力して下さい。

=IF(ROWS($2:2)>COUNTIF($B:$B,E$1),"",INDEX($A:$D,MATCH(E$1&ROWS($2:2),$Z:$Z,0),4))

　次に、E3セルの書式設定を、A2セルと同じ設定にしてから、E3セルに次の数式を入力して下さい。

=IF(ROWS($2:2)>COUNTIF($B:$B,E$1),"",INDEX($A:$D,MATCH(E$1&ROWS($2:2),$Z:$Z,0),1))

　尚、表中の日付が、必ず全て同じ日付であるならば、E3セルに入力する数式を次の様に変えても構わないと思います。（と言いますか、日付が同じであるなら、個別に表示する意味が無い様にも思えますが）

=$A$2

　以上の作業が済んでから、E3～G3の範囲をコピーして、同じ列の4行目以下に貼り付けて下さい。
　次に、E列～G列の範囲をまとめてコピーして、H列から右に向かって、店舗の数だけ貼り付けて下さい。
　そして、A列を除く各日付欄と同じ列の1行目の各セルに、店舗名を入力して下さい。
　以上で準備は完了で、後は、A～D列のセルにデータを入力して行かれると、各店舗毎のリストが、自動的に作成されます。

お礼

こんにちわ！
ご回答有り難うございます。

振り分けは全く問題御座いませんでしたが、Ａ～Ｄの内容が翌営業日になった際に、前日分の振り分けた内容も消えてしまいます。
（Ａ～Ｃの内容は営業日毎に変わり、前日分は消えてしまいます。振り分けた後はＡ～Ｃの内容が変わってても消えて欲しくないのです。）

説明不足で申し訳御座いません。大変恐縮ですが、ご教授頂けると幸いです。

よろしくお願いします。

補足

（）内のＡ～ＣはＡ～Ｄの間違いです。申し訳御座いません。