エクセル線の上に1以上、下に0以下を表示して位置をそろえたいです。

Question

エクセルで、300くらいあるデータをある条件で40のグループに分け、全て違う列に表示します。全てのグループを降順に並べ替えた後、数値が0と1の間に線を引き、その線の位置が全グループ揃うようにしたいです。
毎回数値は変わるので並び替えはマクロを使用し、線を引くのは条件付書式を使用しようと思いますが、線の位置をそろえる(全てのグループの0の位置をそろえる)ためには目で確認してドラッグしてセルの位置を移動させるしかないでしょうか？
一本の線の上に全てのグループの、1以上のデータが表示され、下には0以下のデータが表示されるようにしたいです。
40グループあるので毎回ドラッグしているとかなり時間がかかってしまいます。
グループ分けする前に並び替えをし、グループ分けしたとしても、0の位置を揃えて表示する方法が思いつきません。
何かいい方法があれば教えてください。

soixante · Accepted Answer

追加です。ついでなんで、やっぱりもうひとつのVer.も作っちゃいました。
こっちもお試しください。たぶんこっちかもしれない。

【使い方】
１．新規ブックを開く（シートは2枚以上）
２．Sheet1 のA1セルに元データを貼る
３．以下のコードを実行

’--------------------------------------------------------------------------------
Sub BBB()
'変数宣言
Dim r As Integer, c As Integer, j As Integer, k As Integer
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim LstRow As Integer, StRow As Integer, EdRow As Integer, TgtRow As Integer
Dim Dic As Object, Gnam As Variant, Mykeys As Variant, Rng As Range
Dim Cnt As Integer, MaxCnt As Integer, MaxG As Integer, Kosu As Variant

Set Ws1 = Worksheets(1)
Set Dic = CreateObject("Scripting.Dictionary")

'前日のシート（2枚目）を削除
Application.DisplayAlerts = False
Worksheets(2).Delete
Set Ws2 = Worksheets.Add(After:=Worksheets(1))
Application.DisplayAlerts = True

'元データをグループ名昇順、数値降順で並び替え
Ws1.Select
LstRow = Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = Range(Cells(1, 1), Cells(LstRow, 3))
Rng.Sort _
    Key1:=Cells(1, 1), Order1:=xlAscending, _
    Key2:=Cells(1, 3), Order2:=xlDescending, _
    Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom

'A列を縦にループしてグループ名の非重複リストを作成
r = 2
Do While Cells(r, 1).Value <> ""
    Gnam = Cells(r, 1).Value
    If Not Dic.Exists(Gnam) Then
        Dic.Add Gnam, Gnam
    End If
    r = r + 1
Loop
Mykeys = Dic.keys
ReDim Kosu(Dic.Count)

'Sheet2に40グループを展開し、Sheet1の見出しを貼る
Application.ScreenUpdating = False
For k = 0 To Dic.Count - 1
    Set Rng = Ws1.Range(Ws1.Cells(1, 1), Ws1.Cells(1, 7))
    Rng.Copy
    With Ws2.Cells(1, 7 * k + 1)
        .PasteSpecial Paste:=xlPasteColumnWidths
        .PasteSpecial Paste:=xlPasteAll
    End With
Next k

'各グループの0.1以上のデータ数と最大グループを取得
r = 2: k = 0: j = 2
Do Until r = LstRow
   Do While Cells(j, 1).Value = Mykeys(k)
        If Cells(j, 3).Value >= 0.1 Then
            Cnt = Cnt + 1
        End If
        j = j + 1
    Loop
    Kosu(k) = Cnt
    If Cnt > MaxCnt Then
        MaxCnt = Cnt
        MaxG = k
    End If
    k = k + 1
    Cnt = 0
    r = j - 1
Loop

Debug.Print "最大個数は" & MaxCnt & "で、最大グループは" & MaxG + 1; "番目のG"
Debug.Print "基準線は" & MaxCnt + 1 & "の下の線"

'Sheet2に各グループのデータを所定の位置に展開し、区切り線を入れる
r = 2: k = 0
Do Until r = LstRow
    j = 2
    Do Until Cells(j, 1).Value = Mykeys(k)
        j = j + 1
    Loop
    StRow = j
    j = Cells(1, 1).End(xlDown).Row
    Do Until Cells(j, 1).Value = Mykeys(k)
        j = j - 1
    Loop
    EdRow = j
    Range(Cells(StRow, 1), Cells(EdRow, 7)).Copy
    TgtRow = MaxCnt - Kosu(k) + 2
    With Ws2
        .Cells(TgtRow, 7 * k + 1).PasteSpecial Paste:=xlPasteAll
        With .Range(.Cells(MaxCnt + 1, 7 * k + 1), .Cells(MaxCnt + 1, 7 * k + 7)).Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 5
            .Weight = xlMedium
        End With
    End With
    k = k + 1
    r = j
Loop

Ws2.Select
Cells(1, 1).Select

'変数開放
Set Ws1 = Nothing
Set Ws2 = Nothing
Set Dic = Nothing
Set Rng = Nothing
Set Mykeys = Nothing
Set Kosu = Nothing

MsgBox "End."
End Sub
’--------------------------------------------------------------------------------

どうでしょう？
40回ドラッグの日々からの解放をお祈りします（笑。

soixante · Answer

ご希望の形となって良かったです。
やっぱり二つめの形でしたね。

最後のエラーメッセージは良く分かりません。コードを見てもらうと分かりますが、
終了時にメッセージボックスで、End. と表示させてます。
わたしの手元のダミーデータのテストでは正常に動作するんですけどねえ。
すみません、分かりません。

念のためデータが正しく処理されてるかは確認いただき、問題なければ日々の業務に
ご使用いただいて良いでしょう。

以下は余談なんですが。
このコードの不具合発生時などのメンテのためにも、良かったらVBAも学んでみてください。少しずつでいいと思います。

また、自動記録マクロだけでは出来ることがかなり限られるため、このようなVBAによる記述を知っておくと、
非常に柔軟性が出ますので、びっくりするくらい省力化できる業務がい〜っぱいあります。
めっちゃラクできますし、強烈な武器となります。
よろしければどうぞ。

soixante · Answer

再び登場です（笑。
コメント拝見しました。なるほど基本的な設計が変わりますね。

＞①元データはグループ名、氏名、データ
＞③データは小数点第1位までで、0以下0.1以上で分ける
→　まあこの２つは何とでもなります。

＞②完成は別シートに、グループ名、氏名、データ、ブランク4列

→　ここ、ここ。ここがキモなのです。このコードのまさにハイライトです。
　シートをまたぐ処理は根本から変わります。
　ちょっと正確に読み取れたか分かりませんが、やってみました。
　一回実行して感想をお聞かせください。

【最初の使い方】
１．新規ブックを開く。（シート数は2枚以上にしてください）
２．Sheet1のA1セルに元データを貼る。
３．で、以下のコードを実行。

’-------------------------------------------------------------------------------------
Sub AAA()

'変数宣言
Dim r As Long, c As Integer, j As Long, k As Integer
Dim LstRow As Long, Rng As Range
Dim Dic As Object, Gnam As Variant, Mykeys As Variant
Dim MaxCnt As Long, MaxG As Integer, Kosu As Variant
Dim Ws1 As Worksheet, Cnt As Integer
Dim StRow As Integer, EdRow As Integer, TgtRow As Integer

Set Ws1 = Worksheets(1)
Set Dic = CreateObject("Scripting.Dictionary")

'前日のシート（2枚目以降）を削除
Application.DisplayAlerts = False
For k = Worksheets.Count To 2 Step -1
    Worksheets(k).Delete
Next k
Application.DisplayAlerts = True

'元データをグループ名昇順、数値降順で並び替え
LstRow = Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = Range(Cells(1, 1), Cells(LstRow, 3))
Rng.Sort _
    Key1:=Cells(1, 1), Order1:=xlAscending, _
    Key2:=Cells(1, 3), Order2:=xlDescending, _
    Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom

'A列を縦にループしてグループ名の非重複リストを作成
r = 2
Do While Cells(r, 1).Value <> ""
    Gnam = Cells(r, 1).Value
    If Not Dic.Exists(Gnam) Then
        Dic.Add Gnam, Gnam
    End If
    r = r + 1
Loop
Mykeys = Dic.keys

'グループごとに新規シートを作成し、全シートにSheet1の見出し行を貼る
Application.ScreenUpdating = False
Set Rng = Ws1.Range(Ws1.Cells(1, 1), Ws1.Cells(1, 7))

For k = 0 To Dic.Count - 1
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Mykeys(k)
    Rng.Copy
    Cells(1, 1).PasteSpecial Paste:=xlPasteAll
Next k
ReDim Kosu(k)
Ws1.Select

'グループごとの0.1以上のデータ数を数える
j = 2: k = 0: Cnt = 0: MaxCnt = 0: MaxG = 0
For r = 2 To LstRow
    Do While Cells(j, 1).Value = Mykeys(k)
        If Cells(j, 3).Value >= 0.1 Then Cnt = Cnt + 1
        j = j + 1
    Loop
    Kosu(k) = Cnt
    If Cnt > MaxCnt Then
        MaxG = k
        MaxCnt = Cnt
    End If
    Cnt = 0
    k = k + 1
    r = j - 1
Next r

Debug.Print "最大個数は" & MaxCnt & "で, 最大グループは" & MaxG + 1 & "番目のG"
Debug.Print "基準線は" & MaxCnt + 1 & "の下の線"

'各グループのデータを各シートの所定位置に配置し区切り線を入れる
For k = 0 To Dic.Count - 1
    r = 2
    Do Until Cells(r, 1).Value = Mykeys(k)
        r = r + 1
    Loop
    StRow = r
    r = Cells(1, 1).End(xlDown).Row
    Do Until Cells(r, 1).Value = Mykeys(k)
        r = r - 1
    Loop
    EdRow = r
    
    Range(Cells(StRow, 1), Cells(EdRow, 3)).Copy
    TgtRow = MaxCnt - Kosu(k) + 2
    With Worksheets(k + 2)
        .Cells(TgtRow, 1).PasteSpecial Paste:=xlPasteAll
        With .Range(.Cells(MaxCnt + 1, 1), .Cells(MaxCnt + 1, 7)).Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 5
            .Weight = xlMedium
        End With
    End With
Next k

'体裁整え
For k = 2 To Worksheets.Count
    Worksheets(k).Select
    Cells(1, 1).Select
Next k
Ws1.Select

'変数の開放
Set Ws1 = Nothing
Set Rng = Nothing
Set Dic = Nothing
Set Mykeys = Nothing
Set Kosu = Nothing

MsgBox "End."

End Sub
’-------------------------------------------------------------------------------------

毎日の作業のようなので、前日のシートを削除してから開始するコードとしています。
というわけで、前日シートを手作業で削除する必要はありません。

【日々の使い方】
１．このブックを開く
２．Sheet1のデータを全消去
３．その日の新しいデータをSheet1のA1セルに貼り付け
４．で、実行。

※少し気になるのが、「ブランク4列」という記述・・・。
　ひょっとして、元データSheet1 の次のシート、Sheet2　に、40グループを全部展開ということですかね。
　そのグループの間を4列空ける？　ということかなあ。

まあ一度回してみてください。感想は何なりとどうぞ。
もう乗りかかった船ですから、出来うる限りで改良します。

ちょいと飲み会なんかも続くので（汗）、レスポンスが遅くなったらすみませんが気長に開けといてくださいm(_ _)m

soixante · Answer

再度お邪魔します。コメント有難うございました。

ところで、あなたのやりたいことには合っていましたか？　それなら問題ないですが。

＞この通りに一度やってみます

とりあえず、わたしが書いたコードは、あなたのデータの形式に合っていない可能性があります。
不明点が多いので、勝手に形式を想像して書いただけなので。
したがって、このコードを基に、あなたのデータ形式に合わせてリバイスしてもらえばいいですが、
あなたのVBAの知識によっては難しいかもしれません。その際はお知らせください。

私が書いたコードにあなたのデータを合わせるのではなくて、
あなたのデータに合わせたコードを組まねば意味がないからです。
データの配置や、グループ分けの基準によっては根本から違うコードになる可能性があるためです。

今回やろうとしている作業は、まさにパソコンの得意とするところです。
決まったルールに則って、決まった作業をする、という点。
毎日データ数が変わるわけですから自動記録のマクロでは無理で、VBAで記述してやらねばなりません。

こんなの毎日いちいち手作業で40グループもドラッグするなんてナンセンスですからPCにやらせましょう。
今回のコードは、私の手元のダミーデータ（300行、40グループ）で処理してみると、1-2秒で終わります。
ちゃんと正しい指示さえしてやれば、ものすごく速く処理してくれるわけなので、使わない手はありません。
浮いた時間でコーヒーブレイクでも入れておけばいいのです（-.-)y-~~~  
ラクできるところはラクしましょう（^^

soixante · Answer

#2、＃4です。試しに組んでみました。ただ、元データの形（配置、項目等）が分からないこと、や、グループ分けの基準（「ある条件」）が分からないので以下の形でやっています。ダミーデータを簡単に作って、テストしてみてください。たぶんやりたいことはこういうことかと。・元データはA列にグループ名、B列にデータの値　という２列１組とする・A1セルは「グループ名」、B1セルは「データ」という見出し。データは２行目から始まっている。・「０以下」と「１以上」という記載から、データはすべて整数とする・「グループ分けしてすべて違う列に表示」の方法については、同じシートの、C列以降右に展開して表示。 ----------------------------------------------------------------------------------------- Sub XXX() '変数宣言 Dim r As Long, c As Integer, j As Long, k As Integer Dim LstRow As Long, LstCol As Integer, Rng As Range, Dic As Object Dim Gnam As Variant, Mykeys As Variant Dim MaxRow As Long, MaxCol As Integer, Kugiri As Variant Set Dic = CreateObject("Scripting.Dictionary") '元データをグループ名昇順、数値降順で並び替え LstRow = Cells(Rows.Count, 1).End(xlUp).Row Set Rng = Range(Cells(1, 1), Cells(LstRow, 2)) Rng.Sort _ Key1:=Cells(1, 1), Order1:=xlAscending, _ Key2:=Cells(1, 2), Order2:=xlDescending, _ Header:=xlYes, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom 'A列を縦にループしてグループ名の非重複リストを作成 r = 2 Do While Cells(r, 1).Value <> "" Gnam = Cells(r, 1).Value If Not Dic.exists(Gnam) Then Dic.Add Gnam, Gnam End If r = r + 1 Loop Mykeys = Dic.keys '見出し行をグループ数だけ横に展開 For k = 0 To Dic.Count - 1 Cells(1, 2 * k + 3).Value = "G名" Cells(1, 2 * k + 4).Value = "データ" Next k k = 2 * (Dic.Count) + 2 ReDim Kugiri(k) '元データを各列に割り振り r = 2: k = 0 Do While Cells(r, 1).Value <> "" j = r Do While Cells(j, 1).Value = Mykeys(k) LstRow = Cells(Rows.Count, 2 * k + 3).End(xlUp).Row + 1 Cells(LstRow, 2 * k + 3).Value = Cells(j, 1).Value Cells(LstRow, 2 * k + 4).Value = Cells(j, 2).Value j = j + 1 Loop k = k + 1 r = j Loop '全グループの中で１以上データの境目を取得しながら1以上データ数が最大の列を探す LstCol = Cells(1, Columns.Count).End(xlToLeft).Column MaxRow = 2: MaxCol = 4 For c = 4 To LstCol Step 2 r = 2 Do Until Cells(r, c).Value < 1 r = r + 1 Loop If r > MaxRow Then MaxRow = r MaxCol = c End If Kugiri(c) = r Next c '各グループを基準線に合わせるようずらす Application.ScreenUpdating = False On Error Resume Next For c = 3 To LstCol Step 2 j = Kugiri(c + 1) Set Rng = Range(Cells(2, c), Cells(Cells(2, c).End(xlDown).Row, c + 1)) Rng.Cut Cells(MaxRow - j + 2, c) Next c On Error GoTo 0 With Range(Cells(MaxRow, 3), Cells(MaxRow, LstCol)).Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 5 .Weight = xlMedium End With Application.ScreenUpdating = True '変数の開放 Set Rng = Nothing Set Dic = Nothing Set Mykeys = Nothing Set Kugiri = Nothing MsgBox "End." End Sub ----------------------------------------------------------------------------------------- ご不明点あればお知らせください。

soixante · Answer

#2です。
さっきの回答で一箇所漏れがあったので。

各列に展開したあと、そのグループ内で昇順並び替え

が要りますね。すみません。

このあとに40列ループで、1以上データ数の最大列を探しに行ってください。
そしたら出来ます。

銀鱗 · Answer

データがどのように並んでいるのか不明なことから、とりあえず並べ替えについては考えないことにする。

並べ替えが正しく行われたとして条件付き書式を設定すればよいと思うが、自分は何か勘違いしているのだろうか。

ってか、質問文には０と１の間に罫線を引くとなっているのだから、その結果5行目だろうと9行目だろうとそこに罫線が引かれれば正解ではないのか。
それとも「他のグループと同じフォーマットになるように足りない分の空白行を増やして並べ替えを行いたい」という一文が抜けているのだろうか。（←下種パー：エスパーの一種と思って欲しいｗ）
実際にやりたい状態の図（画像）を添付するとよいと思う。

soixante · Answer

確かにマクロを使うべきでしょうね。
元データの詳細が分からないのでざっくりですが私なら以下のイメージでいきます。

元データがA列に縦に300入っている。
40グループに分け、違う列に展開。
その場合、各グループのデータは、一行めから縦に並べる(上詰め）。

その40列をループし、1以上のデータ数が最も多い列（グループ）を探す。

そうすると、その列の区切り線が来る位置が決まるので、残り39列をそれに合わせてセットし直し。

こんな流れで組んでみてはどうでしょう？

銀鱗 · Answer

やりたいことが今ひとつ伝わってこないが、条件付き書式って自分で書いてないか。
条件を設定すれば良いだけだ。
その条件をどうすればよいのか分からないと言うことだろうか。

エクセル 線の上に1以上、下に0以下を表示して位置をそろえたいです。

追加です。

ご希望の形となって良かったです。

再び登場です（笑。

再度お邪魔します。

#2、＃4です。

#2です。

データがどのように並んでいるのか不明なことから、とりあえず並べ替えについては考えないことにする。

確かにマクロを使うべきでしょうね。

やりたいことが今ひとつ伝わってこないが、条件付き書式って自分で書いてないか。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

エクセル線の上に1以上、下に0以下を表示して位置をそろえたいです。