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

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

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

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

●質問者: tororosoba
●カテゴリ:コンピュータ
✍キーワード:コピー コラム シフト ポイント マクロ
○ 状態 :終了
└ 回答数 : 5/5件

▽最新の回答へ

1 ● きゃづみぃ
●20ポイント

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

◎質問者からの返答

takntさん、

ありがとうございます。

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


2 ● Ktwo
●500ポイント ベストアンサー

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

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

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/

◎質問者からの返答

Ktwoさん、

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

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


3 ● Silvanus
●100ポイント

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

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

仰せの様なことは実現できていると思います。定数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

◎質問者からの返答

Silvanusさん、

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

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


4 ● spyglass
●100ポイント

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

◎質問者からの返答

spyglassさん

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

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


5 ● hathi
●100ポイント

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

◎質問者からの返答

hathiさん、

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

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

関連質問


●質問をもっと探す●



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