エクセルVBAについて質問です。次のページにあるようなマクロを作ってください。

http://hatena88.web.fc2.com/hatena/newpage2.shtml
なお、現在勉強中ですので、下記の質問の回答者4の方のような解説を付け加えていただいた方には追加ポイントのおまけを付けます。もしそれが必要なければマクロだけ教えていただいても結構です。よろしくお願いします。
http://q.hatena.ne.jp/1158311664

回答の条件
  • 1人2回まで
  • 登録:2006/09/18 22:17:15
  • 終了:2006/09/19 04:14:11

回答(2件)

id:bonlife No.1

回答回数421ベストアンサー獲得回数752006/09/19 00:49:53

ポイント150pt

以下のようなマクロでいかがでしょうか。

説明が不足している箇所がありましたら、ご指摘いただければ補足説明いたします。

Sub Macro1()

' データシートを変数に保存

Dim DataSheet As Worksheet
Set DataSheet = ActiveSheet

' データの並び替え (今回はA列、B列の昇順でソート)
    
    Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, _
        Key2:=Range("B1"), Order2:=xlAscending

' 変数の初期化

Dim rowNum, eachRowNum, sheetNum As Integer
rowNum = 1      ' 対象とするデータシートの行番号
eachRowNum = 1  ' コピー先の各シートの行番号
sheetNum = 2    ' コピー先のシートのインデックス

' コピー処理

' A列の値がブランク("")でない間、処理を実行
While Cells(rowNum, 1).Value <> ""
    ' A列のある行の値が次の行の値と等しい場合の処理
    While Cells(rowNum, 1).Value = Cells(rowNum + 1, 1).Value
        ' コピー先となるシートが存在しない場合、シートを追加
        If sheetNum > Worksheets.Count Then
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            DataSheet.Activate ' データシートをアクティヴにする
        End If
        ' コピー先のシートの行にデータシートの行の値を代入
        Worksheets(sheetNum).Rows(eachRowNum).Value = Rows(rowNum).Value
        rowNum = rowNum + 1         ' データシートの対象行を移動
        eachRowNum = eachRowNum + 1 ' コピー先シートの対象行を移動
    Wend
    ' A列のある行の値が次の行の値と等しくない場合の処理
    ' (A列の値が1つしかない場合などの処理)
    ' コピー先となるシートが存在しない場合、シートを追加
    If sheetNum > Worksheets.Count Then
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            DataSheet.Activate
    End If
    ' コピー先のシートの行にデータシートの行の値を代入
    Worksheets(sheetNum).Rows(eachRowNum).Value = Rows(rowNum).Value
    eachRowNum = 1          ' データシートの対象行を初期化 (新しいシートでは1行目を対象行とする)
    rowNum = rowNum + 1     ' コピー先シートの対象行を移動
    sheetNum = sheetNum + 1 ' コピー先のシートのインデックスを増加
Wend

End Sub

元のデータがあるシートをソートした上で実行するようにしておりますので、それが問題ある場合、元のシートを残す処理を事前に追加する必要がありますので、ご注意ください。

参考になれば幸いです。

id:taroemon

ご回答ありがとうございます。

パーフェクトにできました。

2006/09/19 04:09:07
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912006/09/19 01:28:39

ポイント150pt

こんな感じでしょうか。

Sub DevideData()
    Dim lastLine As Long
    lastLine = Range("A65535").End(xlUp).Row
' データのソート
    Range("A1:C" & lastLine).Sort _
        Key1:=Range("A1"), Order1:=xlAscending, _
        Key2:=Range("B1"), Order2:=xlAscending, _
        Key3:=Range("C1"), Order3:=xlAscending

    Dim wsNum As Integer
    wsNum = 2

    Dim num As Long
    Do While lastLine > 0
' 先頭データと同値の数をカウント
        num = Application.WorksheetFunction.CountIf(Range("A1:C" & lastLine), Cells(1, 1).Value)
' データをコピー
        Worksheets(1).Rows("1:" & num).Copy

' シートがなければ作成
        If wsNum > Worksheets.Count Then
         Worksheets.Add after:=Worksheets(wsNum - 1)
        Else
         Worksheets(wsNum).Activate
        End If
        
' 対象シートへコピー
        Worksheets(wsNum).Rows("1").Select
        ActiveSheet.Paste
        Worksheets(1).Select
        
' 元データを削除
        Rows("1:" & num).Delete
        lastLine = lastLine - num
        wsNum = wsNum + 1
    Loop
End Sub

id:taroemon

ご回答ありがとうございます。

2006/09/19 04:10:07

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません