人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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

●質問者: taroemon
●カテゴリ:コンピュータ
✍キーワード:VBA エクセル ポイント マクロ 勉強
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ●
●150ポイント

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

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

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

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

参考になれば幸いです。

◎質問者からの返答

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

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


2 ● Mook
●150ポイント

こんな感じでしょうか。

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

◎質問者からの返答

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

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ