Find All Empty Blank Cells Or KeyWord In A Column

[william516]

Ok been playing with this code for a little while and I will explain what it does. It takes any blank/no value cell in column "E" and copies that row to another sheet called "MISSED INSPECTION ITEMS" It is tied to a virtual button and the command for it is issued when that excel button is pressed. So far it works great but with one minor problem. I need to also have it pick up text keywords. For example. It needs to look for a blank/no value cell in column "E" or the words "NO ACCESS" etc. I have tried adding "IF" statements with "or" like prev code examples but never have any luck. The other thing is that the way the code is written on the "MISSED INSPECTION ITEMS" page it will clear the row the second a letter is entered into the "E" column. I am trying to make it so that whatever status is chosen on the "MISSED INSPECTION ITEMS" page will remove it from that page and update the "INITIATING DEVICES" page column "E'

So far no luck here is what I have so far (this is what is assigned to an excel module and activated via run macro or the button)


Sub Find_missed_devices()
Dim sh1 As Worksheet, sh2 As Worksheet, rng As Range, lr As Long
Set sh1 = Sheets("INITIATING DEVICES")
Set sh2 = Sheets("MISSED INSPECTION ITEMS")

'Set the range for the inspection results column
lr = sh1.Cells(Rows.Count, 2).End(xlUp).Row
Set rng = sh1.Range("E7:E" & lr)

'Isolate the missing or empty results columns and copy rows to sheet 2 (MISSED INSPECTION ITEMS)
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Copy sh2.Range("A7")
With sh2
If Application.CountIf(.Range("C7", .Cells(Rows.Count, 3).End(xlUp).Offset(0, 1)), "") > 0 Then
.Range("C7", .Cells(Rows.Count, 3).End(xlUp).Offset(0, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delet e
End If
End With
End Sub


This is what is actually in the page code of the "MISSED INSPECTION ITEMS" page

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr As Long, rng As Range
lr = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("E7:E" & lr)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, rng) Is Nothing Then
For Each c In Sheets("INITIATING DEVICES").Range("E:E")
If Target.Offset(0, -1).Value = c.Value And Target.Offset(0, -2).Value = c.Offset(0, -1).Value Then
c.Offset(0, 1) = Target.Value
Exit For
End If
Next
Target.EntireRow.Delete
End If
End Sub


I will keep playing with this as I have tons of backups to keep myself busy
Thanks again

[patel]

attach please a sample file for testing

[william516]

Here is a "working" file, well not really but it has some real information and gives a general idea of what is going on.

I attempted to upload the file with no luck, if you give me an email I can send it, it is over the limit to post according to the forums.

[Excel Fox]

Try uploading it here, and share the link

4shared.com - free file sharing and storage (http://www.4shared.com/)

[william516]

Ok here is the link for the file, sorry it took so long.

http://www.4shared.com/folder/cutVSTcp/_online.html

If there are any further questions just let me know, and once again thanks for the help

[patel]

need an account for downloading, this is better Wikisend: free file sharing service (http://www.wikisend.com/)

[Excel Fox]

Yes, my bad. agree with Patel. Thought it used to be free. Please upload on a free site.

[Excel Fox]

Had a 4shared account myself. Here's what you can try for the first macro



Sub Find_missed_devices()

Dim shtInitiatingDevices As Worksheet, shtMissedInspectionItems As Worksheet
Dim lngLastRow As Long
Dim rngEach As Range, rng As Range

Set shtInitiatingDevices = Sheets("INITIATING DEVICES")
Set shtMissedInspectionItems = Sheets("MISSED INSPECTION ITEMS")

'Set the range for the inspection results column
lngLastRow = shtInitiatingDevices.Cells(Rows.Count, 2).End(xlUp).Row
Set rng = shtInitiatingDevices.Range("E7:E" & lngLastRow)
'Isolate the missing or empty results columns and copy rows to sheet 2 (MISSED INSPECTION ITEMS)
Application.EnableEvents = False
For Each rngEach In rng
If Len(Trim(rng.Value)) = 0 Or UCase(rng.Value) = "NO ACCESS" Then
rng.Offset(, -4).Resize(, 5).Copy shtMissedInspectionItems.Cells(shtMissedInspection Items.Rows.Count, 1).End(xlUp)(2)
End If
Next rngEach
With shtMissedInspectionItems
If Application.CountIf(.Range("C7", .Cells(Rows.Count, 3).End(xlUp).Offset(0, 1)), "") > 0 Then
.Range("C7", .Cells(Rows.Count, 3).End(xlUp).Offset(0, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delet e
End If
End With
Application.EnableEvents = True

End Sub

[Excel Fox]

And for the worksheet change event in MISSED INSPECTION ITEMS, try this



Private Sub Worksheet_Change(ByVal Target As Range)

Dim lngLastRow As Long, rng As Range
lngLastRow = Me.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Me.Range("E7:E" & lngLastRow)

If (Not Intersect(Target, rng) Is Nothing) And (Target.Cells.Count = 1) Then
For Each c In Sheets("INITIATING DEVICES").Range("A2:A" & Sheets("INITIATING DEVICES").Cells(Rows.Count,1).End(xlUp).Row)
If c.Value & c.Offset(, 1).Value & c.Offset(, 2).Value & c.Offset(, 3).Value = _
Me.Cells(Target.Row, 1).Value & Me.Cells(Target.Row, 2).Value & Me.Cells(Target.Row, 3).Value & Me.Cells(Target.Row, 4).Value Then
c.Offset(, 4).Value = Target.Value
Target.EntireRow.Delete
Exit For
End If
Next
End If

End Sub

[william516]

Ok I attempted to work with this code and I keep getting an error on the line of code

If Len(Trim(rng.Value)) = 0 Or UCase(rng.Value) = "NO ACCESS" Then. Debug us picking this up. Now I checked to make sure it was not a spelling error and the columns are the correct ones etc. When using UCase it shouldn't matter if the code was in lower case even though I made sure to make it all uppercase to match. I will see if it works on a smaller version of the file first as the one I'm testing on right now is a full inspection.

I also reposted the file on a free site, I was not able to get the wiki site to work, it would keep crashing out on file upload

Zippyshare.com - SAMPLE_insepction_converted_061913.xlsm (http://www23.zippyshare.com/v/44056325/file.html)

Thanks again for all your help.