Ensuring all cells are completed

W

wlbamc

Board Regular
Joined
Apr 19, 2016
Messages
99
Office Version
  1. 2016
Hi I have a spreadsheet with a VBA code to automatically move the line to a different tab when something is selected from a dropdown list.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    If Intersect(Target, Range("AD:AD")) Is Nothing Then Exit Sub
    On Error GoTo endit
    Application.EnableEvents = False
    If Target.Value = "Discharged after LTC input" Then
        Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
    ElseIf Target.Value = "Deceased" Then
        Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
    ElseIf Target.Value = "D2A" Then
        Target.EntireRow.Copy Worksheets("D2A").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
    ElseIf Target.Value = "Fast Track" Then
        Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
    ElseIf Target.Value = "Residential" Then
        Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
    ElseIf Target.Value = "No LTC input" Then
        Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
End If
endit:
     Application.EnableEvents = True
     Application.ScreenUpdating = True
End Sub

I now want to ensure that all the cells on that line have a value in them before the above code will let them move the line, and if not it will highlight the ones that need completing (though this part isn't as important). Thanks is advance
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
Sort by date Sort by votes
wlbamc said:
Hi I have a spreadsheet with a VBA code to automatically move the line to a different tab when something is selected from a dropdown list.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    If Intersect(Target, Range("U:U")) Is Nothing Then Exit Sub
    On Error GoTo endit
    Application.EnableEvents = False
    If Target.Value = "Discharged after LTC input" Then
        Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
    ElseIf Target.Value = "Deceased" Then
        Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
    ElseIf Target.Value = "D2A" Then
        Target.EntireRow.Copy Worksheets("D2A").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
    ElseIf Target.Value = "Fast Track" Then
        Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
    ElseIf Target.Value = "Residential" Then
        Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
    ElseIf Target.Value = "No LTC input" Then
        Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
End If
endit:
     Application.EnableEvents = True
     Application.ScreenUpdating = True
End Sub

I now want to ensure that all the cells on that line have a value in them before the above code will let them move the line, and if not it will highlight the ones that need completing (though this part isn't as important). Thanks is advance
mumps said:
When you say:

which columns on that line do you want to check?
Click to expand...
Hi, I want to check columns A - T Thanks
Click to expand...
 
Upvote 0
Try:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    If Intersect(Target, Range("A:U")) Is Nothing Then Exit Sub
    On Error GoTo endit
    Application.EnableEvents = False
    Select Case Target.Column
        Case Is = 21
            If WorksheetFunction.CountA(Range("A" & Target.Row).Resize(, 20)) < 20 Then
                Range("A" & Target.Row).Resize(, 20).SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 3
                MsgBox ("Please enter data in the red cells.")
                Application.EnableEvents = True
                Exit Sub
            End If
            If Target.Value = "Discharged after LTC input" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "Deceased" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "D2A" Then
                Target.EntireRow.Copy Worksheets("D2A").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "Fast Track" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "Residential" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "No LTC input" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            End If
        Case Is <= 19
            If Target <> "" Then
                Target.Interior.ColorIndex = xlNone
            End If
    End Select
endit:
     Application.EnableEvents = True
     Application.ScreenUpdating = True
End Sub
 
Upvote 0
mumps said:
Try:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    If Intersect(Target, Range("A:U")) Is Nothing Then Exit Sub
    On Error GoTo endit
    Application.EnableEvents = False
    Select Case Target.Column
        Case Is = 21
            If WorksheetFunction.CountA(Range("A" & Target.Row).Resize(, 20)) < 20 Then
                Range("A" & Target.Row).Resize(, 20).SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 3
                MsgBox ("Please enter data in the red cells.")
                Application.EnableEvents = True
                Exit Sub
            End If
            If Target.Value = "Discharged after LTC input" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "Deceased" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "D2A" Then
                Target.EntireRow.Copy Worksheets("D2A").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "Fast Track" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "Residential" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "No LTC input" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            End If
        Case Is <= 19
            If Target <> "" Then
                Target.Interior.ColorIndex = xlNone
            End If
    End Select
endit:
     Application.EnableEvents = True
     Application.ScreenUpdating = True
End Sub
Click to expand...
mumps said:
Try:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    If Intersect(Target, Range("A:U")) Is Nothing Then Exit Sub
    On Error GoTo endit
    Application.EnableEvents = False
    Select Case Target.Column
        Case Is = 21
            If WorksheetFunction.CountA(Range("A" & Target.Row).Resize(, 20)) < 20 Then
                Range("A" & Target.Row).Resize(, 20).SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 3
                MsgBox ("Please enter data in the red cells.")
                Application.EnableEvents = True
                Exit Sub
            End If
            If Target.Value = "Discharged after LTC input" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "Deceased" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "D2A" Then
                Target.EntireRow.Copy Worksheets("D2A").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "Fast Track" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "Residential" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "No LTC input" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            End If
        Case Is <= 19
            If Target <> "" Then
                Target.Interior.ColorIndex = xlNone
            End If
    End Select
endit:
     Application.EnableEvents = True
     Application.ScreenUpdating = True
End Sub
Click to expand...

mumps said:
Try:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    If Intersect(Target, Range("A:U")) Is Nothing Then Exit Sub
    On Error GoTo endit
    Application.EnableEvents = False
    Select Case Target.Column
        Case Is = 21
            If WorksheetFunction.CountA(Range("A" & Target.Row).Resize(, 20)) < 20 Then
                Range("A" & Target.Row).Resize(, 20).SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 3
                MsgBox ("Please enter data in the red cells.")
                Application.EnableEvents = True
                Exit Sub
            End If
            If Target.Value = "Discharged after LTC input" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "Deceased" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "D2A" Then
                Target.EntireRow.Copy Worksheets("D2A").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "Fast Track" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "Residential" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            ElseIf Target.Value = "No LTC input" Then
                Target.EntireRow.Copy Worksheets("Inactive").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                Target.EntireRow.Delete
            End If
        Case Is <= 19
            If Target <> "" Then
                Target.Interior.ColorIndex = xlNone
            End If
    End Select
endit:
     Application.EnableEvents = True
     Application.ScreenUpdating = True
End Sub
Click to expand...
Works perfectly, thank you so much
 
Upvote 0
You must log in or register to reply here.

Similar threads

W
  • Question
VBA Code Alteration
Replies
4
Views
342
wlbamc
W
SaraWitch
  • Solved
Autodelete a row from protected sheet and move to another protected sheet based on date
4 5 6
Replies
50
Views
1K
SaraWitch
SaraWitch
J
  • Question
Copy row from Workbook to another when Checkbox is checked
Replies
0
Views
547
JohnTester
J
S
  • Solved
Working with multiple Target Ranges in Worksheet Code
Replies
3
Views
381
sspatriots
S
S
  • Question
I have a problem in audit trail with VBA
Replies
1
Views
153
Joe4
Joe4

Forum statistics

Threads
1,215,148
Messages
6,123,306
Members
449,095
Latest member
Chestertim

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top