エクセルの表を別のシートに２列で表示したい

質問

シート１のＡセルに［商品名＋番号］が入っていてＢセルに値段が入っていて、
８０行位並んでいます。
Ａセル／Ｂセル
冷蔵庫１／50,000
冷蔵庫２／65,000
・・・
冷蔵庫８／73,000
洗濯機１／32,000
・・・

Ｄ１セル　冷蔵庫
Ｄ２セル　洗濯機
・・・
Ｅ１セル　= =IF(D1="","",COUNTIF($A$1:$A$80,D1&"*"))
Ｅ２セル　= =IF(D1="","",COUNTIF($A$1:$A$80,D2&"*"))
・・・
このリストを別シートに２列で表示したいのですが、
（１）左右どちらに表示されてもかまわないが、冷蔵庫は冷蔵庫でまとめて同じ列に表示する
（２）商品名や番号は追加されたり削除されたりするのでどの商品がいくつあるかはＥセルで判断する
（３）左右ほぼ、同じ位の行になるように商品を振り分ける。

としたいのですが、どのようにしたらいいでしょうか？
マクロで構いませんので（他の方法は思いつかないです）アドバイス等でも結構ですので、教えてください。
何かわからない所があったら質問してください。
よろしくお願いします。

回答No.6

kazuhiko5681 · ベストアンサー

なるべく左右の差が縮まるよう次のように考えてみました。

１.シート１のＤ列とＥ列を降順でソートをかける。(下のコードがこれを実行するマクロです。)
２.シート２のＡ列に一番データ量が多い商品を配置
３.シート２のＤ列に次にデータ量の多い商品を配置
４.シート２のＤ列に次にデータ量の多い商品を配置
５.シート２のＡ列に次にデータ量の多い商品を配置
６.４・５を繰り返す。

勿論例のように左右均等に振り分けられる時は必ず振り分けられるようにマクロを組むことは可能かと思いますが、今の私の知識ではこれが精一杯です。私の知識不足をお許し下さい。
あと、マクロで罫線を自動で引くこともできます。このマクロのコードが必要な時はお知らせ下さい。

お礼

このリストは優先順位が高い順に書いてあり上から順に振り分けたいので、
１のソートの部分はちょっと使えません。
が、おかげで振り分けのヒントが得られました。
これから、頑張って作ってみようと思います。
長いこと煩わせてしまい、大変すみませんでした。
どうもありがとうございました。

回答No.5

kazuhiko5681

左右のバランス調整を考えた修正マクロを作ってみました。＃４の想定と同じく作ってあります。

Sub test()

Dim i As Integer
Dim j As Integer
Dim myNum As Integer
Dim myRow1 As Integer
Dim myRow2 As Integer

For i = 2 To Cells(Rows.Count, 4).End(xlUp).Row
If i > 3 Then
myRow1 = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row
myRow2 = Worksheets(2).Cells(Rows.Count, 4).End(xlUp).Row
End If
For j = 4 To Cells(Rows.Count, 1).End(xlUp).Row
myNum = Application.WorksheetFunction.CountIf(Range("A" & j & ":" & "A" & j), Cells(i, 4).Value & "*")
If myNum = 1 Then
If i = 2 Or (i <> 3 And myRow1 < myRow2) Or (i <> 3 And myRow1 = myRow2) Then
If Worksheets(2).Range("A4").Value = "" Then
Worksheets(2).Range("A4").Value = Cells(j, 1).Value
Worksheets(2).Range("B4").Value = Cells(j, 2).Value
Else
Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Cells(j, 1).Value
Worksheets(2).Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Value = Cells(j, 2).Value
End If
ElseIf i = 3 Or myRow1 > myRow2 Then
If Worksheets(2).Range("D4").Value = "" Then
Worksheets(2).Range("D4").Value = Cells(j, 1).Value
Worksheets(2).Range("E4").Value = Cells(j, 2).Value
Else
Worksheets(2).Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Value = Cells(j, 1).Value
Worksheets(2).Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Value = Cells(j, 2).Value
End If
End If
End If
Next j
Next i

End Sub

あなた様のおやりになりたいことが、実現しているはずです。

もし不具合がありましたら、ご遠慮なくお知らせ下さい。

補足

No.4の補足を書いている間に、次の回答が入ってしまいました。

今、試してみたところ
No.4の補足に書いたサンプルデータが、
冷蔵庫　　　　８件／洗濯機　　　９件
電子レンジ　１７件／扇風機　　　３件
パソコン　　１０件／エアコン　２０件
　　　　　　　　　／ワープロ　１３件
----------------------------------
計　　　　　３５件／　　　　　４５件
でならんでいます。
実際には、半分に出来るので、出来ればNo.4に書いたようになって欲しいです。
無理でしたら、無理と書いて頂ければ諦めます。

よろしくお願いします。
このサンプルマクロはこれから勉強させて頂きます。

回答No.4

kazuhiko5681

早速サンプルマクロを作ってみました。
Ａセル／Ｂセル
冷蔵庫１／50,000
冷蔵庫２／65,000
・・・
冷蔵庫８／73,000
洗濯機１／32,000
・・・
このデータがシート１の４行目から入力されていることを想定しています。

Ｄ１セル　冷蔵庫
Ｄ２セル　洗濯機
・・・
このデータがシート１の２行目から入力されていることを想定しています。

書き出すデータはシート２の４行目から書き出されるように設定してあります。

Sub Test()

Dim i As Integer
Dim j As Integer
Dim myNum As Integer

For i = 2 To Cells(Rows.Count, 4).End(xlUp).Row
For j = 4 To Cells(Rows.Count, 1).End(xlUp).Row
myNum = Application.WorksheetFunction.CountIf(Range("A" & j & ":" & "A" & j), Cells(i, 4).Value & "*")
If myNum = 1 Then
If j Mod 2 = 1 Then
If Worksheets(2).Range("A4").Value = "" Then
Worksheets(2).Range("A4").Value = Cells(j, 1).Value
Worksheets(2).Range("B4").Value = Cells(j, 2).Value
Else
Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Cells(j, 1).Value
Worksheets(2).Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Value = Cells(j, 2).Value
End If
ElseIf j Mod 2 = 0 Then
If Worksheets(2).Range("D4").Value = "" Then
Worksheets(2).Range("D4").Value = Cells(j, 1).Value
Worksheets(2).Range("E4").Value = Cells(j, 2).Value
Else
Worksheets(2).Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Value = Cells(j, 1).Value
Worksheets(2).Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Value = Cells(j, 2).Value
End If
End If
End If
Next j
Next i

End Sub

あなた様は、ＶＢＡのことをご存知だと思いますので、このコードを実行してみてください。
左右のバランスは考えていませんが、左右にデータが振り分けられて移動するはずです。
左右のバランス調整につきましては、現在思考中です。出来上がり次第お知らせいたしますので、今しばらくお待ち下さい。

なお、実行方法がお解りにならない時はお知らせ下さい。説明させていただきます。

補足

回答ありがとうございます。
が、冷蔵庫は、冷蔵庫で１つの列にしたいのです。

この作業が３ヶ月に１回位あって、現在は
（１）まず、商品毎の個数を調べ（ここの部分は、Ｄ、Ｅセルに作りました）
（２）全てを足して２で割り、計算して左右に振り分けバランスよく配置し（この部分）
（３）罫線を引く（商品別に太線にし一行毎細線）

という作業をしています。
ですから、ちょうど半分という訳にはいかないと思うのですが、
出来るだけ、左右が同じ位になるようにしたいのです。
現在のサンプルデータとして、
冷蔵庫　８件、洗濯機　９件、電子レンジ　１７件、扇風機　３件、エアコン　２０件 パソコン　１０件、ワープロ　１３件
があります。
これを
冷蔵庫　　　８件／電子レンジ　１７件
洗濯機　　　９件／扇風機　　　　３件
パソコン　１０件／エアコン　　２０件
ワープロ　１３件
-----------------------------------
計　　　　４０件／　　　　　　４０件
この例では、偶然、左右４０件になっていますが、４２件と３８件位ならよしと思っています。
（それ以上はなるべくならないように・・・）
実際のデータは、（８０件）固定ではありません。

もちろん、３ヵ月後には、追加されたり、削除されたりしますので今回の配置にはならなくなります。

ちょっと長くなってしまいましたが、よろしくお願いします。

回答No.3

imogasi

#2の者です。「冷蔵庫０１」等から数字部分を取り除き
比較しないといけないのが、洩れていました。下記にサブルーチンの一例を載せます。Ｃｅｌｌ（ｉ，１）とＪ列を
比較する時、変換後で比較してください。Ｊ列へのセット
も変換後の文字列でしてください。
Function suujidel(c As String)
a = "０１２３４５６７８９"
For i = 1 To Len(Cells(1, 1))
For j = 1 To 9
If Mid(c, i, 1) = Mid(a, j, 1) Then
b = Mid(c, 1, i - 1)
suujidel = b
Exit Function
End If
Next j
Next i
suujidel = c
End Function
'-------------
Sub test03()
Dim c As String
c = Cells(1, 1)
a = suujidel(c)
MsgBox a
End Sub

回答No.2

imogasi

少し一般化しています。Ａ列に冷蔵庫、洗濯機のほかに
約２５０品目以内なら対応します。
（１）Ａ列にテストデータとしてＳｈｅｅｔ１のＡ１：Ａ１２にa,a,a,a,a,b,a,b,c,c,d,aといれます。
（２）ＶＢＥのＭｏｄｕｌｅ１に下記コードを入れます。
Sub test01()
d = Worksheets("sheet1").Range("a1").CurrentRegion.Rows.Count
'---初期設定。第１行目分処理。
Cells(1, 10) = Cells(1, 1) 'Ｊ列　品名
Cells(1, 11) = 2 'Ｋ列　シートインデックス
Cells(1, 12) = 1 'Ｌ列　書きこみ済み行
Worksheets(2).Cells(1, 1) = Worksheets("sheet1").Cells(1, 1)
Worksheets(2).Cells(1, 2) = 1
m = 1
'-----第２行目以下
For i = 2 To d
For K = 1 To m
If Cells(i, 1) = Cells(K, 10) Then
Worksheets(Cells(K, 11)).Cells(Cells(K, 12) + 1, 1) = Worksheets("sheet1").Cells(i, 1)
Worksheets(Cells(K, 11)).Cells(Cells(K, 12) + 1, 2) = i
Cells(K, 12) = Cells(K, 12) + 1
GoTo p01
End If
Next K
'---新しい品目見つかった時
m = m + 1
Cells(m, 10) = Cells(i, 1)
Cells(m, 11) = Cells(m - 1, 11) + 1
Cells(m, 12) = 1
Worksheets(Cells(m, 11)).Cells(Cells(m, 12), 1) = Worksheets("sheet1").Cells(i, 1)
Worksheets(Cells(m, 11)).Cells(Cells(m, 12), 2) = i
'-----
p01:
Next i
End Sub
実行すると、Ｓｈｅｅｔ２のＡ列のＡ１：Ａ７に
aが７つ持ってきています。
Ｓｈｅｅｔ３のＡ列のＡ１：Ａ２にbが２つを持ってきています。
Ｓｈｅｅｔ４、Ｓｈｅｅｔ５以下説明省略。
（３）本番で修正すること
Ａ．開始行が全て１からになっていますが、Ｃｅｌｌｓ（●,○）の●を修正してください。
Ｂ．シートのインデックス、記録済み行数をＳｈｅｅｔ１のＪ，Ｋ，Ｌ行に持っていますが、邪魔な場合は適当な３列にずらし、関係行のＣｅｌｌｓ（●,○）の○を修正してください
Ｃ．Ｓｈｅｅｔ１のＡ列のデータしかＳｈｅｅｔ２以下に移していませんが、Ｂ、Ｃ・・列でＳｈｅｅｔ２以下に移す必要列
を、Ａ列を移している直後に書き加えてください。
初期設定の部分と２行目以下の部分と２箇所あります。
Ｄ．上記でＳｈｅｅｔ２等のＢ列はＳｈｅｅｔ１の第何行
目から移したかを参考までにセットしています。省いて
下さい。

補足

回答ありがとうございます。
が、よくわかりません。
Sheet3やSheet4がでてくるのですが、１枚のシートへ２列に表示したいのです。

それと、わたしの例にどのように変更したらいいのかもちょっとわかりません。
お手数ですが、そのへんを教えて頂けないでしょうか？

回答No.1

kazuhiko5681

はじめまして。

私でよろしければ、サンプルマクロを作ってみたいと思います。
別シートに２列で表示させたいということですが、サンプルマクロが作りやすくなりますので、別シートの項目名と配置されるセル番地を決めていただけないでしょうか。

お手数をおかけいたしますが、よろしくお願いいたします。

補足

本当は、もっと複雑なので、それをここ載せたらかなり長くなってしまいます。

ですから、別シートの項目名は、
A、Dセルに商品名
B、Eセルに金額
Cセルは空白で、
１行目はタイトル
２行目は作った日付
３行目が項目見出し
４行目からデータの表示
という事でお願いします。
こんな、補足でよろしいでしょうか？