[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『個人別に分けたい』(う)
名前 打率 打数 安打 本塁打 打点 年 佐藤 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.