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

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.
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 Question
VBA Code Alteration
Replies
4
Views
485
wlbamc
W
J
  • Question Question
A VBA Code to Transfer rows of cells across Sheets based on Certain Column Value
Replies
2
Views
116
Peter_SSs
Peter_SSs
J
  • Question Question
Copying Rows Based on Column Value
Replies
1
Views
81
jolivanes
jolivanes
SaraWitch
  • Solved
Autodelete a row from protected sheet and move to another protected sheet based on date
4 5 6
Replies
55
Views
2K
SaraWitch
SaraWitch
G
  • Solved
Skip Row When Column Word Meet
2
Replies
14
Views
358
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,223,911
Messages
6,175,327
Members
452,635
Latest member
laura12345

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