Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


2286 / 13646 ツリー ←次へ | 前へ→

【68934】グループ分け後、枠囲み ひろし 11/4/29(金) 13:02 質問[未読]
【68935】Re:グループ分け後、枠囲み kanabun 11/4/29(金) 15:10 発言[未読]
【68936】Re:グループ分け後、枠囲み oyoyo 11/4/29(金) 18:36 発言[未読]
【68937】Re:グループ分け後、枠囲み UO3 11/4/29(金) 18:46 回答[未読]
【68940】Re:グループ分け後、枠囲み kanabun 11/4/29(金) 20:54 発言[未読]
【68941】Re:グループ分け後、枠囲み UO3 11/4/29(金) 22:26 発言[未読]
【68942】Re:グループ分け後、枠囲み UO3 11/4/29(金) 23:08 発言[未読]
【68938】Re:グループ分け後、枠囲み kanabun 11/4/29(金) 20:19 発言[未読]
【68939】Re:グループ分け後、枠囲み kanabun 11/4/29(金) 20:42 発言[未読]
【68943】Re:グループ分け後、枠囲み ひろし 11/4/30(土) 17:50 お礼[未読]
【68947】Re:グループ分け後、枠囲み UO3 11/5/1(日) 20:49 回答[未読]
【68977】Re:グループ分け後、枠囲み ひろし 11/5/5(木) 12:08 お礼[未読]

【68934】グループ分け後、枠囲み
質問  ひろし  - 11/4/29(金) 13:02 -

引用なし
パスワード
   以前ここでお世話になったものです。また皆様のお力を貸してください。
いま、下記のような表があるとします。


   A       B     C   …
1 バスケ部 相島 康介
2 バレー部 山本 太郎
3 テニス部 川本龍三郎 
4 バレー部 山波  博
5 テニス部 中井度 武
6 野 球部 鈴木 健一
7 バスケ部 中村 太一
8  .     .
   .     .
上のように200人くらいの部活動と生徒の名前を打ち込んでいって、『自動で』このデータを部活ごとにグループ分けして、

以下のようにグループごとに
枠線(線の種類は何でもよいです)で囲み、縦に並べたいのです。
  --------------------
  |バスケ部 相島 康介|
  |バスケ部 中村 太一|
  --------------------   ← グループとグループの間は一行あける。
  --------------------     以下、野球部、バレー部等、部活動の
  |テニス部 川本龍三郎|    グループが縦に同じように続きます。
  |テニス部 中井度 武|   
  --------------------
できるならば、並べる部活動のグループの並べる順番までもコントロールしたいのですが。 

4月からVBAを勉強し始めましたが、まだまだど素人のレベルで、他の人の書かれた
コードを見て、理解・感心するので精一杯です。どうぞよろしく御願いいたします。

--------------------------------------------------------------------------------

【68935】Re:グループ分け後、枠囲み
発言  kanabun  - 11/4/29(金) 15:10 -

引用なし
パスワード
   ▼ひろし さん:

>以前ここでお世話になったものです。また皆様のお力を貸してください。
>いま、下記のような表があるとします。
>
>
>   A       B     C   …
>1 バスケ部 相島 康介
>2 バレー部 山本 太郎
>3 テニス部 川本龍三郎 
>4 バレー部 山波  博
>5 テニス部 中井度 武
>6 野 球部 鈴木 健一
>7 バスケ部 中村 太一
>8  .     .
>   .     .
>上のように200人くらいの部活動と生徒の名前を打ち込んでいって、『自動で』このデータを部活ごとにグループ分けして、
>
> 以下のようにグループごとに
>枠線(線の種類は何でもよいです)で囲み、縦に並べたいのです。
>  --------------------
>  |バスケ部 相島 康介|
>  |バスケ部 中村 太一|
>  --------------------   ← グループとグループの間は一行あける。
>  --------------------     以下、野球部、バレー部等、部活動の
>  |テニス部 川本龍三郎|    グループが縦に同じように続きます。
>  |テニス部 中井度 武|   
>  --------------------
>できるならば、並べる部活動のグループの並べる順番までもコントロールしたいのですが。 
>
> 4月からVBAを勉強し始めましたが、まだまだど素人のレベルで、他の人の書かれた
>コードを見て、理解・感心するので精一杯です。どうぞよろしく御願いいたします。
>
>--------------------------------------------------------------------------------
こんにちは〜
まず、ソートですね。

下のコードは(コメントがいっさい付してありませんが)
C列を作業列にして、そこに グループ番号を書き出しておき、
C列でソートするものです。
C列にグループ番号を書き出すとき、データ行の次の行以下に
ひとつづつ、余計にグループ番号を書き出しておくと、ソートしたとき
各グループの下に スペース行が挿入された格好になりますので、
データブロック単位で 罫線で囲っています。
Sub Try1()
  Dim dic As Object
  Dim i As Long, k As Long, n As Long
  Dim v, vv, sp
  Dim ss As String
  
  Set dic = CreateObject("Scripting.Dictionary")
  With Cells(1).CurrentRegion
    v = .Value
    n = UBound(v)
    ReDim vv(1 To n)
    ReDim sp(1 To n)
    For i = 1 To n
      ss = v(i, 1)
      If Not dic.Exists(ss) Then
        k = k + 1
        vv(i) = k
        sp(k) = k
        dic(ss) = k
      Else
        vv(i) = dic(ss)
      End If
    Next
  End With
  With Range("C1")
    .Resize(n).Value = Application.Transpose(vv)
    .Offset(n).Resize(k).Value = Application.Transpose(sp)
  End With
    
  Dim a As Range
  With Cells(1).CurrentRegion
    .Sort Key1:=.Columns(3), Header:=xlNo
    .Columns(3).Clear
    For Each a In .Resize(, 2).SpecialCells(xlConstants).Areas
      a.BorderAround xlContinuous
    Next
  End With
  
End Sub

ダミーのシートに簡単な表を作成し、シートを見ながら
上のコードを ステップ実行([F8]) して、
あるコードが何をしているのか? ご自分でコメントをつけてみてください。

【68936】Re:グループ分け後、枠囲み
発言  oyoyo  - 11/4/29(金) 18:36 -

引用なし
パスワード
   ひろしさん前回もマルチでしたね。

マルチポストって知ってますか?

Office TANAKA
EXCELの学校

色んなトコに同じ質問するのは、善意で回答してくれてる方へとても
失礼な事なんですよね。

VBAの勉強より、まず社会のルールを学ばれては?

【68937】Re:グループ分け後、枠囲み
回答  UO3  - 11/4/29(金) 18:46 -

引用なし
パスワード
   ▼ひろし さん:

こんにちは

出先のモバイル環境で、エクセルもないのでメモ帳に直接コードを書き込みました。
間違いがたくさんあるかもしれません。罫線のコード、自信がなかったのでkanabunさんの
コードをお借りしています。

最初の club=Array("バスケ部","野球 部","バレー部","テニス部")
ここで、クラブの種類と順序を規定します。規定のないのもは、1つにまとめられて
最後のブロックになります。

しかし、まったくテストもできないどころか、コンパイルもできませんので
さて、どうなりますか。

Option Explicit

Sub Sample()
    Dim club as Variant
    Dim dicV() As Object
    Dim z As Long
    Dim i As Long
    Dim c As Range
    Dim x As Variant

    Application.ScreenUpdating = False

    club=Array("バスケ部","野球 部","バレー部","テニス部")
    z=Ubound(club)+2
    redim dicV(1 to z)
    For i = 1 To Z
        Set dicV(i) = CreateObject("Scripting.Dictionary")
    Next

    With Sheets("Sheet1")
        For Each c In .Range("A1",.Range("A" & .Rows.Count).End(xlUp))
            x = Application.Match(c.Value,v,0)
            If Not IsNumeric(x) then x=Ubound(dicV)
            DicV(x)(c.Value) = c.Offset(,1).Value
        Next
    End With

    z = 1

    With Sheets("Sheet2")
        .Cells.ClearContents
        For i = 1 To Ubound(dicV)
            If DicV(i).Count>0 Then
                .Cells(z,1).Resize(DicV(i).Count).Value = _
                    Application.Transpose(Application.Transpose(DicV(i).Keys))
                .Cells(z,2).Resize(DicV(i).Count).Value = _
                    Application.Transpose(Application.Transpose(DicV(i).Items))
                .Cells(z,1).Resize(dicV(i).Count,2).BorderAround xlContinuous
                z=z+divV(i).Count + 1
            End If
        Next
    End With

    For i = 1 To Ubound(DicV)
        Set DicV(i) = Nothing
    Next

    Application.ScreenUpdating = True

End Sub

【68938】Re:グループ分け後、枠囲み
発言  kanabun  - 11/4/29(金) 20:19 -

引用なし
パスワード
   ▼ひろし さん:
マルチですか? あまり気分のいいもんじゃないですね

先ほどのコード、すこし修正(simple化)しました。
Sub Try2()
  Dim dic As Object
  Dim i As Long, k As Long, n As Long
  Dim v, vv, sp
  Dim ss As String
  
  Set dic = CreateObject("Scripting.Dictionary")
  With Cells(1).CurrentRegion
    v = .Value
    n = UBound(v)
    ReDim vv(1 To n, 0)
    ReDim sp(1 To n, 0)
    For i = 1 To n
      ss = v(i, 1)
      If Not dic.Exists(ss) Then
        k = k + 1
        vv(i, 0) = k
        sp(k, 0) = k
        dic(ss) = k
      Else
        vv(i, 0) = dic(ss)
      End If
    Next
  End With
  With Range("C1")  '作業列にグループ番号を書き込む
    .Resize(n).Value = vv
    .Offset(n).Resize(k).Value = sp
  End With
    
  With Cells(1).CurrentRegion
    .Sort Key1:=.Columns(3), Header:=xlNo
    .Columns(3).Clear
    .Resize(, 2).SpecialCells(xlConstants) _
        .BorderAround xlContinuous
  End With
  
End Sub


現在は、出現順に、グループ化しています。

> できるならば、並べる部活動のグループの並べる順番までもコントロールしたいのですが。
これは、現在、考慮していません。
部活動の名称ははじめから決まっていて、その並び順も決まっているということですか?

【68939】Re:グループ分け後、枠囲み
発言  kanabun  - 11/4/29(金) 20:42 -

引用なし
パスワード
   ▼kanabun さん:

>> できるならば、並べる部活動のグループの並べる順番までもコントロールしたいのですが。

>部活動の名称ははじめから決まっていて、その並び順も決まっているということ
なら、

【Order】というシートのA列に
[1] バスケ部
[2] バレー部
[3] テニス部
[4] 野球部
のように、部活名を並べたい順にリストしておいてください。

対象シートを選択して、実行です。
Sub Try3()
  Dim dic As Object
  Dim i As Long, k As Long, n As Long
  Dim v, vv, sp
  Dim ss As String
  Dim c As Range
  
  Set dic = CreateObject("Scripting.Dictionary")
  For Each c In Worksheets("Order").Cells(1) _
           .CurrentRegion.Resize(, 1)
    i = i + 1
    dic(c.Value) = i
  Next
    
  With Cells(1).CurrentRegion
    v = .Value
    n = UBound(v)
    ReDim vv(1 To n + dic.Count, 0)
    For i = 1 To n
      ss = v(i, 1)
      vv(i, 0) = dic(ss)
    Next
    For i = n + 1 To n + dic.Count
      k = k + 1
      vv(i, 0) = k
    Next
  End With
  Range("C1").Resize(n + dic.Count).Value = vv
    
  With Cells(1).CurrentRegion
    .Sort Key1:=.Columns(3), Header:=xlNo
    .Columns(3).Clear
    .Resize(, 2).SpecialCells(xlConstants) _
        .BorderAround xlContinuous
  End With
  
End Sub

【68940】Re:グループ分け後、枠囲み
発言  kanabun  - 11/4/29(金) 20:54 -

引用なし
パスワード
   ▼UO3 さん:

>    For i = 1 To Ubound(DicV)
>        Set DicV(i) = Nothing
>    Next

mokutachiさんに教わったんですけど、

ここ、一行で、
   Erase DicV
かな?

【68941】Re:グループ分け後、枠囲み
発言  UO3  - 11/4/29(金) 22:26 -

引用なし
パスワード
   ▼kanabun さん:

>mokutachiさんに教わったんですけど、
>
>ここ、一行で、
>   Erase DicV
>かな?

あぁ、思い出しました。
ありがとうございます。

ということは、DictinaryやCollectionに、複数のDictionaryを
持たせているときには、大元のDictionaryuやCollectionをNothingにすれば
いいのでしょうか。あるいはDictionaryだとRemoveAllがEraseに相当するのでしょうか?

【68942】Re:グループ分け後、枠囲み
発言  UO3  - 11/4/29(金) 23:08 -

引用なし
パスワード
   >                .Cells(z,1).Resize(DicV(i).Count).Value = _
>                    Application.Transpose(Application.Transpose(DicV(i).Keys))
>                .Cells(z,2).Resize(DicV(i).Count).Value = _
>                    Application.Transpose(Application.Transpose(DicV(i).Items))
>

kanabunさんにEraseを教えてもらって、私がアップしたコードをつらつら
眺めていましたら、上の2行、KeysとItemsから、それぞれ1列のみ転記していますので
Transposeは1回だけかければよかったということに気がつきました。

エクセルなしで作業するのは、ほんとに疲れますね。                

【68943】Re:グループ分け後、枠囲み
お礼  ひろし  - 11/4/30(土) 17:50 -

引用なし
パスワード
   最初の投稿者のひろしです。皆様、本当に多くのレスありがとうございます。
まずは皆様がたに、マルチポストをしたことをお詫びしたいと思います。
なるべく多くの方のお力をと思い、他のサイトにもだまって、ほぼ同じ時期に
投稿してしまい、結果として不愉快な思いをされた方がおられることに深く
反省しております。まことに申し訳ありません。

多くの方から教えていただいたコードの意味を一行一行理解している
ところです。本当にありがとうございます。


>▼kanabun さん:

kanabunさん、たびたびのレス、本当にありがとうございます。


>>部活動の名称ははじめから決まっていて、その並び順も決まっているということ
なら、

いいえ、まったく逆で、その並びを場合によって変化させたいと思っております。

【68947】Re:グループ分け後、枠囲み
回答  UO3  - 11/5/1(日) 20:49 -

引用なし
パスワード
   ▼ひろし さん:

やっとエクセルのアル環境に戻ってきました。
で、とりあえずコンパイルしてみますと、案の定、たいむぴすがずいぶんありました。

アップしたSampleの改訂版と、そのつど、任意に順番を規定したいとの要件ですので
kanabunさんの案を踏襲して、"Order"というシートのA列に任意の数の任意の順番の
クラブ名を登録しそれを参照するSample2を。

いずれも、元データは"Sheet1"、それを転移するシートを"Sheet2"としています。

Sub Sample()
    Dim club As Variant
    Dim dicV() As Object
    Dim z As Long
    Dim i As Long
    Dim c As Range
    Dim x As Variant

    Application.ScreenUpdating = False

    club = Array("バスケ部", "野 球部", "バレー部", "テニス部")
    z = UBound(club) + 2
    ReDim dicV(1 To z)
    For i = 1 To z
        Set dicV(i) = CreateObject("Scripting.Dictionary")
    Next

    With Sheets("Sheet1")
        For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
            x = Application.Match(c.Value, club, 0)
            If Not IsNumeric(x) Then x = UBound(dicV)
            dicV(x)(c.Value) = c.Offset(, 1).Value
        Next
    End With

    z = 1

    With Sheets("Sheet2")
        .Cells.Clear
        For i = 1 To UBound(dicV)
            If dicV(i).Count > 0 Then
                .Cells(z, 1).Resize(dicV(i).Count).Value = _
                    Application.Transpose(dicV(i).Keys)
                .Cells(z, 2).Resize(dicV(i).Count).Value = _
                    Application.Transpose(dicV(i).Items)
                .Cells(z, 1).Resize(dicV(i).Count, 2).BorderAround xlContinuous
                z = z + dicV(i).Count + 1
            End If
        Next
    End With

    Erase dicV

    Application.ScreenUpdating = True

End Sub

Sub Sample2()
    Dim club As Variant
    Dim dicV() As Object
    Dim z As Long
    Dim i As Long
    Dim c As Range
    Dim x As Variant

    Application.ScreenUpdating = False
    
    With Sheets("Order")
      club = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Value
    End With
    z = UBound(club, 1) + 1
    ReDim dicV(1 To z)
    For i = 1 To z
        Set dicV(i) = CreateObject("Scripting.Dictionary")
    Next

    With Sheets("Sheet1")
        For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
            x = Application.Match(c.Value, club, 0)
            If Not IsNumeric(x) Then x = UBound(dicV)
            dicV(x)(c.Value) = c.Offset(, 1).Value
        Next
    End With

    z = 1

    With Sheets("Sheet2")
        .Cells.Clear
        For i = 1 To UBound(dicV)
            If dicV(i).Count > 0 Then
                .Cells(z, 1).Resize(dicV(i).Count).Value = _
                    Application.Transpose(dicV(i).Keys)
                .Cells(z, 2).Resize(dicV(i).Count).Value = _
                    Application.Transpose(dicV(i).Items)
                .Cells(z, 1).Resize(dicV(i).Count, 2).BorderAround xlContinuous
                z = z + dicV(i).Count + 1
            End If
        Next
    End With

    Erase dicV

    Application.ScreenUpdating = True

End Sub

【68977】Re:グループ分け後、枠囲み
お礼  ひろし  - 11/5/5(木) 12:08 -

引用なし
パスワード
   ▼UO3 さん:
お礼が遅くなって申し訳ありませんでした。

『より良いアンサーを』というU03様の姿勢に
頭が下がる思いです。本当にありがとうございます。


皆様のコードを参考にさせてもらい、希望の
ものが作れそうです。重ね重ねお礼申し上げます。

2286 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free