2016-10-12 26 views
1

VBAの新機能で、同じ行のセル値が「完了」の場合にのみ範囲をコピーするコードを作成しています。セルの値に基づく移動範囲

コピーした範囲を別の列に貼り付け、元の範囲を削除します。

セル値が完了に変更されたときに自動的に移動するようにループすることができれば素晴らしいでしょう。私のコードは、これまでのところです:あなたは、このコードは仕事をしたいシートをダブルクリックし、左側に、

Sub Move() 

    Dim r As Range, cell As Range, mynumber As Long 

    Set r = Range("O1:O1000") 

    mynumber = 1 
    For Each cell In r 
     If cell.Value = "Completed" Then 
     Range("Q15:AE15").Select 
     Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 

     If cell.Value = "Completed" Then 
     ActiveCell.Select 
     ActiveCell.Range("B:O").Select 
     Selection.Copy 
     Range("Q14").Select 
     ActiveSheet.Paste 

     End If 

     Next 

    End Sub 
+0

セル、アクティブセル、終了、オフセット)](https://www.youtube.com/watch?v=c8reU-H1PKQ&list=PLNIs-AWhQzckr8Dgmgb3akx_gFMnpxTN5&index=5)。 [Worksheet.Changeイベント(Excel)](https://msdn.microsoft.com/en-us/library/office/ff839775.aspx)を使用するように思えます。 –

答えて

0

あなたは組み込みのイベントWorksheet_Changeを使用する必要があります。シートモジュールにアクセスし、テキストエディタのすぐ上に2つのリストがあり、使用するイベントを選択できます。あなたはそこにこのコードを使用することができます

、それはBから「完了」行のデータを転送します:QにO:AEを:

Private Sub Worksheet_Change(ByVal Target As Range) 
If Target.Cells.Count > 1 Then Exit Sub 

If Not Application.Intersect(Me.Columns(15), Target) Is Nothing Then 
    If Target.Value <> "Completed" Then 
    Else 
     Dim FirstFreeRowInColQ As Long 
     FirstFreeRowInColQ = Me.Range("Q" & Me.Rows.Count).End(xlUp).Row + 1 

     Me.Range("Q" & FirstFreeRowInColQ & ":AE" & FirstFreeRowInColQ).Value = _ 
      Me.Range("B" & Target.Row & ":O" & Target.Row).Value 
    End If 
Else 
End If 

End Sub 
0

私は間のデータと、インサートを移動するためにオフセットを使用しました元の範囲を削除する "削除"機能。オフセットは私が修正しなければならなかった境界のないセルを作成し、それが新しい範囲に移動されたら "Completed"セルもクリアしました。

私はまだループに苦しんでいますが、私は引き続き試してみます。細胞を選択(範囲、 - あなたはこれがのrelavent動画[パート5である[エクセルVBA入門](https://www.youtube.com/playlist?list=PLNIs-AWhQzckr8Dgmgb3akx_gFMnpxTN5)このシリーズを監視する必要があり

Sub Move() 

Dim r As Range, cell As Range, mynumber As Long 

Set r = Range("O1:O1000") 

mynumber = 1 
For Each cell In r 
    If cell.Value = "Completed" Then 
    Range("Q14:AE14").Select 
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 

    End If 

    If cell.Value = "Completed" Then 
    cell.Select 
    cell.Value = "Delete" 
    Range(ActiveCell, ActiveCell.Offset(0, -14)).Select 
    Selection.Copy 
    Range("Q14").Select 
    ActiveSheet.Paste 

     With Selection.Borders(xlEdgeLeft) 
    .LineStyle = xlContinuous 
    .ColorIndex = 0 
    .TintAndShade = 0 
    .Weight = xlThin 
End With 
With Selection.Borders(xlEdgeTop) 
    .LineStyle = xlContinuous 
    .ColorIndex = 0 
    .TintAndShade = 0 
    .Weight = xlThin 
End With 
With Selection.Borders(xlEdgeBottom) 
    .LineStyle = xlContinuous 
    .ColorIndex = 0 
    .TintAndShade = 0 
    .Weight = xlThin 
End With 
With Selection.Borders(xlEdgeRight) 
    .LineStyle = xlContinuous 
    .ColorIndex = 0 
    .TintAndShade = 0 
    .Weight = xlThin 
End With 

    Range("AE14").ClearContents 

    End If 

    If cell.Value = "Delete" Then 
    cell.Select 
    Range(ActiveCell, ActiveCell.Offset(0, -14)).Select 
    Selection.Delete Shift:=xlUp 

    End If 

    Next 

End Sub 
関連する問題