カットして隣のB列に順番にペーストするマクロ

質問

発注と納品の確認マクロを作成しました。
Sheet1の列を検索して、Sheet2にあればその数字のあるセルを赤くするのですが、
それを以下のように変更することは可能でしょうか？
Sheet1の列を検索して、Sheet2にあれば、Sheet2上でその数字をカットして隣のB列に上から順番にペーストします。
宜しくお願いします。

Sub 発注と納品の確認マクロ()
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim myRange1 As Range
Dim myRange2 As Range
Dim c1 As Range
Dim c2 As Range
Dim myCt As Long

Set Ws1 = Worksheets("Sheet1")
Set Ws2 = Worksheets("Sheet2")
Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp))
Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp))

For Each c1 In myRange1
myCt = 0
For Each c2 In myRange2
If c2.Value = c1.Value Then
If myCt = 0 Then
c2.Interior.ColorIndex = 3
Else
c2.Interior.ColorIndex = 43
End If
myCt = myCt + 1
End If
Next c2
If myCt = 0 Then c1.Interior.ColorIndex = 6
Next c1

Set Ws1 = Nothing
Set Ws2 = Nothing
Set myRange1 = Nothing
Set myRange2 = Nothing
End Sub

回答No.3

myRange · ベストアンサー

回答２、myRangeです。
間違いあり。

'------------------------------------
Sheet1のA列には、空白もある
Sheet2のA列には、ダブりもある

という条件であれば次のようになります。

'-------------------------------------------
Sub 発注と納品の確認マクロ()
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim myRange1 As Range
Dim myRange2 As Range
Dim c1 As Range
Dim c2 As Range
Dim myCt As Long

Dim MoveRow As Long

Set Ws1 = Worksheets("Sheet1")
Set Ws2 = Worksheets("Sheet2")
Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp))
Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp))

For Each c1 In myRange1
　　myCt = 0
　　If c1.Value <> "" Then
　　　　For Each c2 In myRange2
　　　　　　If c2.Value <> "" And c2.Value = c1.Value Then
　　　　　　　　If myCt = 0 Then
　　　　　　　　　　MoveRow = MoveRow + 1
　　　　　　　　　　c2.Cut Ws2.Cells(MoveRow, "B")
　　　　　　　　Else
　　　　　　　　　　c2.Interior.ColorIndex = 43
　　　　　　　　End If
　　　　　　　　myCt = myCt + 1
　　　　　　End If
　　　　Next c2

　　　　If myCt = 0 Then
　　　　　　c1.Interior.ColorIndex = 6
　　　　End If
　　End If
Next c1

End Sub
'----------------------------------------

以上です。

回答No.2

myRange

下記●●のコードを修正加筆。

'-----------------------------------
Sub 発注と納品の確認マクロ()
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim myRange1 As Range
Dim myRange2 As Range
Dim c1 As Range
Dim c2 As Range
Dim myCt As Long

　　　Dim MoveRow As Long '●●

Set Ws1 = Worksheets("Sheet1")
Set Ws2 = Worksheets("Sheet2")
Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp))
Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp))

For Each c1 In myRange1
myCt = 0
For Each c2 In myRange2
If c2.Value = c1.Value Then
If myCt = 0 Then

　　MoveRow = MoveRow + 1　　　　　　'●●
　　c2.Cut Ws2.Cells(MoveRow, "B")　　'●●

Else
c2.Interior.ColorIndex = 43
End If
myCt = myCt + 1
End If
Next c2
If myCt = 0 Then c1.Interior.ColorIndex = 6
Next c1

Set Ws1 = Nothing
Set Ws2 = Nothing
Set myRange1 = Nothing
Set myRange2 = Nothing
End Sub
'------------------------------------

以上です。

お礼

ありがとうございました。
私が欲しかった機能でした！
即応いただきまして本当にありがとうございました。

回答No.1

kybo

c2.Interior.ColorIndex = 3

を

c2.Cut c2.Offset(, 1)

に変更してみて下さい。

お礼

早速の返信ありがとうございます！
右隣に移動してくれました！
ただ、移動して上から順番に空白なく並んで欲しいのですがそれは難しいでしょうか。