エクセルで次のようなのマクロ作成をお願いいたします。

Sheet1に次のようなデータが入っています。
1,2,3行目にデータの区切り位置
4行目にデータの名称
5行目以下データ

A列 B列 C列
1  2  3
3  4  5
5  6  7
a  b  c
1  1  1
2  2  2
3  3  3
4  4  4
5  5  5
6  6  6
7  7  7
8  8  8
  
このデータを、Sheet2,Sheet3,Sheet4,Sheet5に次のように整理して欲しいです。
Sheet2  
A列 B列 C列
a  b  c
1  1  1
   2  2
     3

Sheet3  
A列 B列 C列
a  b  c
2  3  4
3  4  5
  
Sheet4  
A列 B列 C列
a  b  c
4  5  6
5  6  7

Sheet5  
A列 B列 C列
a  b  c
6  7  8
7  8
8

回答の条件
  • 1人2回まで
  • 登録:2009/02/23 12:23:22
  • 終了:2009/02/23 18:13:10

ベストアンサー

id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692009/02/23 17:08:10

ポイント35pt

なんとなく原因はわかります。

通常シートを増やすとSheet1、Sheet2・・・とシート名がついていき、オブジェクト名もSheet1、Sheet2・・・とついていきます。

ここでシートの名前をSheet1とSheet2と入れ替えても、オブジェクト名は変わりません。

そんな感じで今の場合はシート名がSheet1だけど、オブジェクト名が違うシートとなっているのでしょう。

それで、コード中のシートの取得をシート名に変えました。

これで、シートの名前がSheet1~Sheet5のシートが5つあればうまく動作すると思います。

Sub Macro1()
    Dim i As Integer
    Dim j As Integer
    Dim r As Integer
    Dim lastRow As Long
    
    With Worksheets("Sheet1")
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        
        For j = 1 To 3
            Worksheets("Sheet2").Cells(1, j).Value = .Cells(4, j).Value
            r = 2
            For i = 5 To .Cells(1, j).Value + 4
                Worksheets("Sheet2").Cells(r, j).Value = .Cells(i, j).Value
                r = r + 1
            Next i
            Worksheets("Sheet3").Cells(1, j).Value = .Cells(4, j).Value
            r = 2
            For i = .Cells(1, j).Value + 5 To .Cells(2, j).Value + 4
                Worksheets("Sheet3").Cells(r, j).Value = .Cells(i, j).Value
                r = r + 1
            Next i
            Worksheets("Sheet4").Cells(1, j).Value = .Cells(4, j).Value
            r = 2
            For i = .Cells(2, j).Value + 5 To .Cells(3, j).Value + 4
                Worksheets("Sheet4").Cells(r, j).Value = .Cells(i, j).Value
                r = r + 1
            Next i
            Worksheets("Sheet5").Cells(1, j).Value = .Cells(4, j).Value
            r = 2
            For i = .Cells(3, j).Value + 5 To lastRow
                Worksheets("Sheet5").Cells(r, j).Value = .Cells(i, j).Value
                r = r + 1
            Next i
        Next j
    End With

End Sub
id:iwayuru_kami

有難うございました。

上記マクロで無事動きました。

2009/02/23 18:12:50

その他の回答(1件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692009/02/23 13:08:59

ポイント35pt
Sub Macro1()
    Dim i As Integer
    Dim j As Integer
    Dim r As Integer
    Dim lastRow As Long
    lastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    
    For j = 1 To 3
        Sheet2.Cells(1, j).Value = Sheet1.Cells(4, j).Value
        r = 2
        For i = 5 To Sheet1.Cells(1, j).Value + 4
            Sheet2.Cells(r, j).Value = Sheet1.Cells(i, j).Value
            r = r + 1
        Next i
        Sheet3.Cells(1, j).Value = Sheet1.Cells(4, j).Value
        r = 2
        For i = Sheet1.Cells(1, j).Value + 5 To Sheet1.Cells(2, j).Value + 4
            Sheet3.Cells(r, j).Value = Sheet1.Cells(i, j).Value
            r = r + 1
        Next i
        Sheet4.Cells(1, j).Value = Sheet1.Cells(4, j).Value
        r = 2
        For i = Sheet1.Cells(2, j).Value + 5 To Sheet1.Cells(3, j).Value + 4
            Sheet4.Cells(r, j).Value = Sheet1.Cells(i, j).Value
            r = r + 1
        Next i
        Sheet5.Cells(1, j).Value = Sheet1.Cells(4, j).Value
        r = 2
        For i = Sheet1.Cells(3, j).Value + 5 To lastRow
            Sheet5.Cells(r, j).Value = Sheet1.Cells(i, j).Value
            r = r + 1
        Next i
    Next j
End Sub
id:iwayuru_kami

回答有難うございます。

上記マクロを動かしてみたのですが

実行時エラー'424'

オブジェクトが必要です。

と表示され

Sheet2.Cells(1, j).Value = Sheet1.Cells(4, j).Value

の部分で止まってしまいました。

何が原因だか分かりますでしょうか?

2009/02/23 15:29:30
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692009/02/23 17:08:10ここでベストアンサー

ポイント35pt

なんとなく原因はわかります。

通常シートを増やすとSheet1、Sheet2・・・とシート名がついていき、オブジェクト名もSheet1、Sheet2・・・とついていきます。

ここでシートの名前をSheet1とSheet2と入れ替えても、オブジェクト名は変わりません。

そんな感じで今の場合はシート名がSheet1だけど、オブジェクト名が違うシートとなっているのでしょう。

それで、コード中のシートの取得をシート名に変えました。

これで、シートの名前がSheet1~Sheet5のシートが5つあればうまく動作すると思います。

Sub Macro1()
    Dim i As Integer
    Dim j As Integer
    Dim r As Integer
    Dim lastRow As Long
    
    With Worksheets("Sheet1")
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        
        For j = 1 To 3
            Worksheets("Sheet2").Cells(1, j).Value = .Cells(4, j).Value
            r = 2
            For i = 5 To .Cells(1, j).Value + 4
                Worksheets("Sheet2").Cells(r, j).Value = .Cells(i, j).Value
                r = r + 1
            Next i
            Worksheets("Sheet3").Cells(1, j).Value = .Cells(4, j).Value
            r = 2
            For i = .Cells(1, j).Value + 5 To .Cells(2, j).Value + 4
                Worksheets("Sheet3").Cells(r, j).Value = .Cells(i, j).Value
                r = r + 1
            Next i
            Worksheets("Sheet4").Cells(1, j).Value = .Cells(4, j).Value
            r = 2
            For i = .Cells(2, j).Value + 5 To .Cells(3, j).Value + 4
                Worksheets("Sheet4").Cells(r, j).Value = .Cells(i, j).Value
                r = r + 1
            Next i
            Worksheets("Sheet5").Cells(1, j).Value = .Cells(4, j).Value
            r = 2
            For i = .Cells(3, j).Value + 5 To lastRow
                Worksheets("Sheet5").Cells(r, j).Value = .Cells(i, j).Value
                r = r + 1
            Next i
        Next j
    End With

End Sub
id:iwayuru_kami

有難うございました。

上記マクロで無事動きました。

2009/02/23 18:12:50
  • id:SALINGER
    ひょっとして、Sheet1しか無かったようですね。
    Sheet2~Sheet5まで、既にあるのかと思ってました。
    自動でシートを追加するコードを書いてもいいですが、手動で挿入しても実行できます。
  • id:iwayuru_kami
    SALINGER様
    有難うございます。
    再度Sheet2~Sheet5を挿入して確認したのですが
    同じ内容のエラーが発生しました。
    どの部分がおかしいか分かりますでしょうか?

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

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

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

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