複数行挿入のマクロ作成をお願いします。もしそのまま使える完全な回答をしていただいた最初の回答者の方に、お気持ちですが500ポイント差し上げます。


コラムH、K、Oすべてに値が入っている該当行をもう一行挿入するというものです。【例】3行目のコラムH(H3)、K(K3) 、O(O3)すべてに値が入っていた場合は3行目をコピーし、4行目として挿入したいです。その際、本来4行目に入っていた行は5行目へとシフトします。

是非お力添えを頂ければと思います。

回答の条件
  • URL必須
  • 1人2回まで
  • 13歳以上
  • 登録:2010/09/28 19:22:56
  • 終了:2010/09/28 22:41:09

ベストアンサー

id:Ktwo No.2

Ktwo回答回数21ベストアンサー獲得回数52010/09/28 21:35:50

ポイント500pt

こんな感じでいいですか?

(そのまま使用できる状態を回答するのは、勉強する機会を奪うようで、あまり良くないのかもしれませんが・・・)

Public Sub Check_H_K_O_and_CopyRow()
On Error GoTo Check_H_K_O_and_CopyRow_Error

Dim i       As Double

    For i = 1 To 65535

        'H,K,Oのいずれかが「空」ならTHEN、それ以外はELSEへ
        If IsEmpty(Range("H" & CStr(i)).Value) Or _
            IsEmpty(Range("K" & CStr(i)).Value) Or _
            IsEmpty(Range("O" & CStr(i)).Value) _
        Then
        
            'H,K,Oが全て「空」であれば、終了
            If IsEmpty(Range("H" & CStr(i)).Value) And _
                IsEmpty(Range("K" & CStr(i)).Value) And _
                IsEmpty(Range("O" & CStr(i)).Value) _
            Then
                Exit For
            End If
        
        Else
            
            '行コピー&行挿入貼付け
            Rows(i).Copy
            i = i + 1
            Rows(i).Insert Shift:=xlDown
            
        End If

    Next i

    Application.CutCopyMode = False
    Range("A1").Select

    MsgBox "Finished"
    
    Exit Sub

Check_H_K_O_and_CopyRow_Error:

    MsgBox "!! Error !!" & vbCr & vbCr & Err.Description

End Sub

・Excelシートの1行目から処理しています。

・H,K,Oのセルが全て「空」の行で終了します。


<Excel VBA 入門講座>

http://excelvba.pc-users.net/

id:tororosoba

Ktwoさん、

ご迅速なご回答、誠にありがとうございました!

確認させていただきました。

2010/09/28 22:29:23

その他の回答(4件)

id:taknt No.1

きゃづみぃ回答回数13538ベストアンサー獲得回数11982010/09/28 19:48:08

ポイント20pt

If Cells(3, "H") <> "" And Cells(3, "K") <> "" And Cells(3, "O") <> "" Then

Rows("3:3").Copy

Rows("3:3").Insert Shift:=xlDown

End If

こういう感じになります。

もし 複数回 行うならば、一番下の行から やってくのが 原則となります。


http://q.hatena.ne.jp/1285669374

id:tororosoba

takntさん、

ありがとうございます。

今回はシート全体で行いたかったので、少し目的とずれがありました。

2010/09/28 22:37:42
id:Ktwo No.2

Ktwo回答回数21ベストアンサー獲得回数52010/09/28 21:35:50ここでベストアンサー

ポイント500pt

こんな感じでいいですか?

(そのまま使用できる状態を回答するのは、勉強する機会を奪うようで、あまり良くないのかもしれませんが・・・)

Public Sub Check_H_K_O_and_CopyRow()
On Error GoTo Check_H_K_O_and_CopyRow_Error

Dim i       As Double

    For i = 1 To 65535

        'H,K,Oのいずれかが「空」ならTHEN、それ以外はELSEへ
        If IsEmpty(Range("H" & CStr(i)).Value) Or _
            IsEmpty(Range("K" & CStr(i)).Value) Or _
            IsEmpty(Range("O" & CStr(i)).Value) _
        Then
        
            'H,K,Oが全て「空」であれば、終了
            If IsEmpty(Range("H" & CStr(i)).Value) And _
                IsEmpty(Range("K" & CStr(i)).Value) And _
                IsEmpty(Range("O" & CStr(i)).Value) _
            Then
                Exit For
            End If
        
        Else
            
            '行コピー&行挿入貼付け
            Rows(i).Copy
            i = i + 1
            Rows(i).Insert Shift:=xlDown
            
        End If

    Next i

    Application.CutCopyMode = False
    Range("A1").Select

    MsgBox "Finished"
    
    Exit Sub

Check_H_K_O_and_CopyRow_Error:

    MsgBox "!! Error !!" & vbCr & vbCr & Err.Description

End Sub

・Excelシートの1行目から処理しています。

・H,K,Oのセルが全て「空」の行で終了します。


<Excel VBA 入門講座>

http://excelvba.pc-users.net/

id:tororosoba

Ktwoさん、

ご迅速なご回答、誠にありがとうございました!

確認させていただきました。

2010/09/28 22:29:23
id:Silvanus No.3

Silvanus回答回数174ベストアンサー獲得回数672010/09/28 21:51:19

ポイント100pt

その様な行が連続するケースの処理方法や、チェックするカラムをその度毎に変更する必要性等

いろいろ不明な点がありますので、これがベストのものとは言い難いですが、一応このマクロで

仰せの様なことは実現できていると思います。定数RowStartとRowEndには、チェックを行なう

行の範囲(各々最初と最後の行番号)を指定して下さい。

Option Explicit

Sub Hatena_TororoSoba_100928()

Const RowStart As Integer = 1

Const RowEnd As Integer = 100

Dim Count1 As Integer

For Count1 = RowStart To RowEnd

' カラムH,K,Oはそれぞれ8,11,15番目のカラムです。

If Application.CountA(Cells(Count1, 8), Cells(Count1, 11), Cells(Count1, 15)) = 3 Then

With Rows(Count1)

.Copy

.Insert Shift:=xlDown

End With

Count1 = Count1 + 1

End If

Next

End Sub

http://q.hatena.ne.jp/1285669374

id:tororosoba

Silvanusさん、

ありがとうございました。

確認させていただきました!

2010/09/28 22:39:26
id:spyglass No.4

spyglass回答回数455ベストアンサー獲得回数292010/09/28 21:59:45

ポイント100pt

Excel2003としてお答えします。

即興で作ったので構文が汚くてすみません。

以下、マクロになります。


Sub Macro1()

i = 1

Do

If Cells(i, "H") <> "" And Cells(i, "K") <> "" And Cells(i, "O") <> "" Then

Rows(i).Select

Selection.Copy

Rows(i + 1).Select

Selection.Insert Shift:=xlDown

i = i + 1

End If

i = i + 1

Loop Until i > 65535

Application.CutCopyMode = False

Range("A1").Select

End Sub


上記まで

URLはダミーです。

http://q.hatena.ne.jp/1285669374

id:tororosoba

spyglassさん

ありがとうございました。

確認させていただきました!

2010/09/28 22:39:29
id:hathi No.5

hathi回答回数204ベストアンサー獲得回数462010/09/28 22:08:52

ポイント100pt

1シートの1行目から最終使用行までのチェックです。

URLが必要なのですね。

  最終行の行番号の取得は

  http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_030_100.html

Sub test()

myr1 = 1

myr2 = ActiveSheet.Cells.SpecialCells(xlLastCell).Row

For i = myr2 To myr1 Step -1

If Cells(i, "H") <> "" And Cells(i, "K") <> "" And Cells(i, "O") <> "" Then

Rows(i + 1).Insert shift:=xlDown

Rows(i).Copy Destination:=Rows(i + 1)

End If

Next i

End Sub

id:tororosoba

hathiさん、

ありがとうございました!

確認させていただきました!

2010/09/28 22:39:31
  • id:Ktwo
    イルカ頂きまして、ありがとうございますm(__)m
    と、1点修正です。
    3行目のDimは、
    Dim i As Long
    にして下さい///

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

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

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

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