Excel VBA質問箱 IV

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

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


13293 / 76734 ←次へ | 前へ→

【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
3 hits

【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 お礼

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