【最大10000ポイント】当たる!!質問投稿キャンペーン!

発注と納品の確認マクロを作成しました。
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

このQ&Aに関連する最新のQ&A

A 回答 (3件)

回答2、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
'----------------------------------------

以上です。
    • good
    • 0

 


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

'-----------------------------------
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
'------------------------------------

以上です。
    • good
    • 0
この回答へのお礼

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

お礼日時:2010/04/03 14:52

c2.Interior.ColorIndex = 3





c2.Cut c2.Offset(, 1)

に変更してみて下さい。
    • good
    • 0
この回答へのお礼

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

お礼日時:2010/04/03 14:08

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!


人気Q&Aランキング