マクロによる条件での行の入力と削除

質問

初めまして、よろしくお願いします。
　次のような二枚のシートがあります
　シート１

　　　　　Ａ　　Ｂ　　Ｃ　　
１　　　　
２　　　　　　
・　　　　　
９９　　　　　
１００　２３　　　
１０１　２５　　
１０２　３１　　
１０３　３４　
１０４　４３　
１０５　４４　
１０６　４９　
１０７　５０　
１０８　５５　
１０９　６０　
１１０　
１１１
　・
　・

　シート２

　　　　　Ａ　　Ｂ　　Ｃ　　
１　　　　
２　　　　　　
・　　　　　
９９　　　　　
１００　２３　　１　２　３　　
１０１　２５　　４　５　６
１０２　３１　　７　８　９　　　　
１０３　３４　　０　１　２　
１０４　４３　　３　４　５　　　　
１０５　４４　　６　７　８
１０６　４９　　９　０　１
１０７　５０　　２　３　４
１０８　５５　　５　６　７
１０９　６０　　８　９　０
１１０　
１１１
　・
　・
シート１とシート２のA列に入っている数字が通し番号です。シート２では加えてその通し番号のデーター数字がＢ列、Ｃ列、Ｄ列に入っています。
のこシート１の通し番号３１が削除、代わりに通し番５番と５１番を追加し、
　シート１

　　　　　Ａ　　Ｂ　　Ｃ　　
１　　　　
２　　　　　　
・　　　　　
９９　　　　　
１００　　５
１０１　２３　　　
１０２　２５　　　　
１０３　３４　
１０４　４３　
１０５　４４　
１０６　４９　
１０７　５０　
１０８　５１
１０９　５５　
１１０　６０　
１１１　
１１２
　・
　・
マクロを実行すると
　シート２

　　　　　Ａ　　Ｂ　　Ｃ　　
１　　　　
２　　　　　　
・　　　　　
９９　　　　　
１００　　５
１０１　２３　　１　２　３　　
１０２　２５　　４　５　６　　　
１０３　３４　　０　１　２　
１０４　４３　　３　４　５　　　　
１０５　４４　　６　７　８
１０６　４９　　９　０　１
１０７　５０　　２　３　４
１０８　５１
１０９　５５　　５　６　７
１１０　６０　　８　９　０
１１１　
１１２
　・
　・
シート２がこように通し番号３１が入っていた行番１０２行が削除され、新たに通し番５番が行番１００に、５１番が行番１０８に挿入追加されるマクロを教えていただきたく、よろしくお願いします。

回答No.6

tom04 · ベストアンサー

No.1・3・4です！

何度もごめんなさい。
ごく単純に・・・
行削除のあとすぐに行挿入し、Sheet1のA100～A199　セルをSheet2にそのままコピー＆ペーストだと間違いがないかもしれません。

Sub test3()
Dim i, j As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
Application.ScreenUpdating = False
For j = 199 To 100 Step -1
For i = 100 To 199
If WorksheetFunction.CountIf(Range(ws1.Cells(100, 1), ws1.Cells(199, 1)), ws2.Cells(j, 1)) = 0 Then
ws2.Rows(j).Delete
ws2.Rows(j).Insert
End If
Next i
Next j
Application.ScreenUpdating = True
Range(ws1.Cells(100, 1), ws1.Cells(199, 1)).Copy Destination:=ws2.Cells(100, 1)
End Sub

こんなんではどうでしょうか？m（＿ ＿）m

お礼

何度も修正回答いただきありがとうございます。こちらのやり方で、うまくできました。大変助かりました。お付き合いいただき、ありがとうございます。

回答No.5

keithin

また後出しの「じつは…」あるとダメかもしれません。

Sub macro1()
　On Error Resume Next
　With Worksheets("Sheet1").Range("B100:D199")
　.Formula = "=IF(VLOOKUP($A100,Sheet2!$A$100:$D$199,COLUMN(),FALSE)<>"""",VLOOKUP($A100,Sheet2!$A$100:$D$199,COLUMN(),FALSE),NA())"
　.SpecialCells(xlCellTypeFormulas, xlErrors).ClearContents
　.Value = .Value
　Worksheets("Sheet1").Range("A100:D199").Copy Destination:=Worksheets("Sheet2").Range("A100")
　.ClearContents
　End With
End Sub

お礼

回答ありがとうございます。”後出し”は大変失礼しました。回答いただいたやり方でうまくできました。大変助かりました。

回答No.4

tom04

No.1・3です！
たびたびごめんなさい。

投稿した後で気づいたのですが、コード内にCOUNTIF関数を使っていて、検索範囲が列全体になっています。
200行目以降に100～199行にあるデータと一致するものがある場合は希望通りの動きにならないと思います。
そこでもう一度コードを訂正したものを載せておきます。

Sub test2()
Dim i, j As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
Application.ScreenUpdating = False
For j = 199 To 100 Step -1
For i = 100 To 199
If WorksheetFunction.CountIf(Range(ws1.Cells(100, 1), ws1.Cells(199, 1)), ws2.Cells(j, 1)) = 0 Then
ws2.Rows(j).Delete
End If
If ws1.Cells(i, 1) < ws2.Cells(j, 1) And ws1.Cells(i, 1) > ws2.Cells(j - 1, 1) Then
ws2.Rows(j).Insert
ws2.Cells(j, 1) = ws1.Cells(i, 1)
End If
Next i
Next j
Application.ScreenUpdating = True
End Sub

※　ちゃんと希望通りに動くことを期待しています。
何度も失礼しました。m（＿ ＿）m

お礼

回答ありがとうございます。こちらのやり方で範囲指定は満足できましたが、やはり行番２００以降のデーターと、なぜだか頭の行番の通し番号、例では２３が後尾についてしまうのは残念です。

回答No.3

tom04

No.1です！
補足を読ませてもらいました。

前回のコードは100行目～最終行まで！としていますので、希望通りにならなかったようですね！
前回のコードをそのまま利用する場合は2行だけの変更で大丈夫だと思います。
100～199行の間での操作だとすると、
各Sheetの最終行の部分を　199　に訂正すればOKかと思います。

＞For j = ws2.Cells(Rows.Count, 1).End(xlUp).Row To 100 Step -1
＞For i = 100 To ws1.Cells(Rows.Count, 1).End(xlUp).Row

の行を
それぞれ
>For j = 199 To 100 Step -1
>For i = 100 To 199

としてみてください。

これで何とか希望通りの動きにならないでしょうか？m（＿ ＿）m

お礼

補足の回答ありがとうございます。こちらのお願い通りに行範囲はできました。
ただ、この変更では追加分が後尾につき、行番２００以降に入力されているデーターがこちらも後尾まで移動してしまうのが残念です。こちらのわがままに付き合っていただき、ありがとうございます。

回答No.2

imogasi

こんなのはVBAでやる理由は無いのでは。手入力と、並べ替えと行削除操作で出来るのでは。
VBAでやらなければならない理由は？
ーー
既出の回答のお礼を見ても、ただやって見て、結果が思い通りでした、を見るだけで、回答の処理のロジック（手順）の理解など出来てないのでは。少しぐらい変更できるレベルで無いと、質問して、回答をもらっても無駄では。
それで少し内容が追加・変更されると、追加質問になる。
例の挙げ方も不自然。左端の番号は行番号かデータなのか明示のこと。
何がしたいのかよくわからない。＞行番１０２行が削除され、新たに通し番５番が行番１００に、５１番が行番１０８に挿入追加される、のは、どういう理由で１０２や５や５１などが出てきたのか？

ーー
削除で言えば
Sub test06()
x = InputBox("削除する番号")
r = Range("a:a").Find(x).Row
Rows(r).EntireRow.Delete
End Sub
という方法も在る。全行下から、削除する番号を探していく既回答とは別の方法。
追加は最下行の下行に追加データをVBAで入力し（しかしプログラムでデータ入力は、追加行が多数あれば、Inputboxやコードの中に書き込む方法とは別の他の方法を考える必要がある。）ソートすればよいのでは。
シート１とシート２は、そのデータ内容で追加や削除について、何か関連させるのかな。

お礼

回答ありがとうございます。削除する番号を探していく方法は大変参考になりました。

回答No.1

tom04

こんにちは！
一例です。

データは両Sheet共、100行目からとしています。
標準モジュールにコピー＆ペーストしてマクロを試してみてください。

Sub test()
Dim i, j As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
For j = ws2.Cells(Rows.Count, 1).End(xlUp).Row To 100 Step -1
For i = 100 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
If WorksheetFunction.CountIf(ws1.Columns(1), ws2.Cells(j, 1)) = 0 Then
ws2.Rows(j).Delete
End If
If WorksheetFunction.CountIf(ws2.Columns(1), ws1.Cells(i, 1)) = 0 And _
ws1.Cells(i, 1) <> "" And ws1.Cells(i, 1) < ws2.Cells(j, 1) And _
ws1.Cells(i, 1) > ws2.Cells(j - 1, 1) Then
ws2.Rows(j).Insert
ws2.Cells(j, 1) = ws1.Cells(i, 1)
End If
Next i
Next j
End Sub

こんな感じではどうでしょうか？m(__)m

お礼

回答ありがとうございます。回答いただきました内容でうまくできました。しかしもしよろしければですが、こちらの説明不足で行番２００から別のデーターが入力されているために、行番２００番前まで、できればマクロ実行後に２００番以降の行にデーターが入力されている行位置がマクロ実行前と同じ位置になっていればありがたいです。わがまま言って申し訳ありません。よろしくお願いします。

補足

お礼の説明の、さらに補足です。シート１とシート２のどちらのシートにも行番２００番以降から、別のデーターが入力されています。
　大変失礼しました。解る方、よろしくお願いします。