[[20060114134347]] 『個人別に分けたい』(う) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『個人別に分けたい』(う)

 名前   打率   打数   安打   本塁打  打点   年
 佐藤   0.333   333    111    30    100    1
 山田   0.250   400    100    40    130    1
 高橋   0.300   500    150    20    75    1
 佐藤   0.313   450    141    38    112    2
 山田   0.286   420    120    44    129    2
 高橋   0.366   530    194    17    58    2
 このような表を別のシートに個人別で分けたいのですが、どのようにすればよいのでしょうか?
 ちなみに列の項目は実際のところ、もっとたくさんあり、人の数ももっと多いですし、年々増加していくので更新が必要となります。
 宜しくお願いします。EXCEL2003使用です。

 vbaです。
 データのあるシート名を"Sheet1"と想定しています。

 Sub test()
 Dim ws As Worksheet, wsData As Worksheet
 Dim dic As Object, x, y, i As Long
 Dim rng() As Range, n As Long, r As Range
 Set wsData = Sheets("sheet1") ' <- 変更?
 Set dic = CreateObject("scripting.dictionary")
 For Each r In wsData.Range("a2", wsData.Range("a" & Rows.Count).End(xlUp))
     If Not IsEmpty(r) Then
         If Not dic.exists(r.Value) Then
             n = n + 1: ReDim Preserve rng(1 To n)
             Set rng(n) = r.Resize(, 7)
             dic.Add r.Value, n
         Else
             Set rng(dic(r.Value)) = Union(rng(dic(r.Value)), r.Resize(, 7))
         End If
     End If
 Next
 x = dic.keys: y = dic.items
 If dic.Count < 1 Then Exit Sub
 For i = 0 To UBound(x)
     On Error Resume Next
     Set ws = Sheets(x(i))
     If ws Is Nothing Then
         Set ws = Sheets.Add(after:=Sheets(Sheets.Count))
         ws.Name = x(i)
     End If
     Err.Clear
     ws.Range("a1:g1").Value = wsData.Range("a1:g1").Value
     rng(y(i)).Copy ws.Range("a2")
     Set ws = Nothing
 Next
 Erase x, y, rng
 End Sub
 (seiya)


 ありがとうございます、もうひとつ教えて下さい。
 実際、列はRまであります。
 この場合はどこを修正すれば宜しいのですか?
 (う)

 r.Resize(, 7) を r.Resize(,18) に変更。(seiya)

 度々、ありがとうございます。m(__)m
 またできない時があれば宜しくお願いします。
 (う)

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.