恐れ入りますが、エクセルマクロの作成をお願いいたします。


  A B
1 ? ◎
2 ! ●
3 * 〇


といった表があるとして、
A1~A3まで選択された状態にするとします。

ここからマクロをスタートすると、
何行入れますか?
何列目のコピーをしますか?

とインプットBOXで連続で聞いてくるようにします。

下記具体例ですが、

仮に、
何行入れますか?→2(※1)
何列目のコピーをしますか?→2(※2)

と入力されたとすると、

各行の間に2行(※1で入力された数値)ずつ行が挿入され、
A列から1列目(※2で入力された数値)の数値が挿入された行の中の一番上にコピーされるようにする

にはどうしたらよいでしょうか?

上記の例でしたら、
結果は

  A B
1 ? ◎
2 ◎
3
4 ! ●
5 ●
6
7 * 〇
8 〇

となります。
スタート時縦にドラッグされていない状態など、指定以外の
動きのときは「誤っています!」等が出るのみで結構です。

お手数をおかけいたしますが、よろしくお願いいたします。

回答の条件
  • 1人2回まで
  • 登録:2008/06/26 17:10:14
  • 終了:2008/06/27 01:55:55

ベストアンサー

id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692008/06/27 00:16:08

ポイント35pt

こんな感じでどうでしょうか。

A列以外でもできるようにしておきました。

Sub Macro()
    Dim gyou As Long        '行
    Dim retu As Long        '列
    Dim StartRow As Long    '開始行
    Dim LastRow As Long     '最終行
    Dim selectRetu          '選択列
    Dim i As Long
    Dim j As Long
    
    '1列だけ選択されているか
    If Selection.Columns.Count > 1 Then
        MsgBox "誤っています!"
        Exit Sub
    End If
    
    'インプットボックス処理
    gyou = Application.InputBox(Prompt:="何行入れますか?", Type:=1)
    If gyou = 0 Then Exit Sub
    
    retu = Application.InputBox(Prompt:="何列目のコピーをしますか?", Type:=1)
    If retu = 0 Then Exit Sub
    
    StartRow = Selection.Row
    LastRow = Selection.Row + Selection.Rows.Count - 1
    selectRetu = Selection.Column
    
    '最終行から処理
    For i = LastRow To StartRow Step -1
        For j = 1 To gyou
            Rows(i + 1).Insert shift:=xlDown
        Next j
        Cells(i + 1, 1).Value = Cells(i, selectRetu + retu - 1).Value
    Next i
End Sub
id:naranara19

いつもご回答ありがとうございます!!!

A列以外というのがとても嬉しいです。

ほんと、助かっています。これからもよろしくお願いいたします。

2008/06/27 01:55:12

その他の回答(1件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912008/06/26 23:27:58

ポイント35pt

とりあえず作ってみました。

こんな感じで、ご希望通りですか?


Sub naranara19()
    If Intersect(Columns("A:A"), Selection) Is Nothing Then
        MsgBox "A列が選択されていません。"
        Exit Sub
    End If

    Dim rg As Range
    Set rg = Intersect(Columns("A:A"), Selection)
    If rg.Count = 1 Then
        MsgBox "A列が複数選択されていません。"
        Exit Sub
    End If
    
    Dim ir As Long
    ir = Application.InputBox("何行入れますか?", Type:=1)
    
    Dim cl As Long
    cl = Application.InputBox("何列目のコピーをしますか?", Type:=1)
    
    If cl <= 0 Or ir <= 0 Then
        MsgBox "誤っています。!"
        Exit Sub
    End If
    
    Dim r As Long
    For r = rg.Row + rg.Count To rg.Row + 1 Step -1
        Rows(r & ":" & r + ir - 1).Insert
        Cells(r, "A").Value = Cells(r - 1, cl).Value
    Next
End Sub
id:naranara19

ありがとうございます!!

完璧に動きました!!!

すばやい回答に感謝いたします!!!!

2008/06/27 01:54:29
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692008/06/27 00:16:08ここでベストアンサー

ポイント35pt

こんな感じでどうでしょうか。

A列以外でもできるようにしておきました。

Sub Macro()
    Dim gyou As Long        '行
    Dim retu As Long        '列
    Dim StartRow As Long    '開始行
    Dim LastRow As Long     '最終行
    Dim selectRetu          '選択列
    Dim i As Long
    Dim j As Long
    
    '1列だけ選択されているか
    If Selection.Columns.Count > 1 Then
        MsgBox "誤っています!"
        Exit Sub
    End If
    
    'インプットボックス処理
    gyou = Application.InputBox(Prompt:="何行入れますか?", Type:=1)
    If gyou = 0 Then Exit Sub
    
    retu = Application.InputBox(Prompt:="何列目のコピーをしますか?", Type:=1)
    If retu = 0 Then Exit Sub
    
    StartRow = Selection.Row
    LastRow = Selection.Row + Selection.Rows.Count - 1
    selectRetu = Selection.Column
    
    '最終行から処理
    For i = LastRow To StartRow Step -1
        For j = 1 To gyou
            Rows(i + 1).Insert shift:=xlDown
        Next j
        Cells(i + 1, 1).Value = Cells(i, selectRetu + retu - 1).Value
    Next i
End Sub
id:naranara19

いつもご回答ありがとうございます!!!

A列以外というのがとても嬉しいです。

ほんと、助かっています。これからもよろしくお願いいたします。

2008/06/27 01:55:12

コメントはまだありません

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

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

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

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