Find blank cells and generate report

[Rick_Stanich]

Hello
The code below is supposed to find blank cells in column E on sheet3, copy some data from adjacent cells, create a string from that data and paste on sheet4 in Column J.
I get duplicate data and or most blank cells?

What the heck did I write.

Option Explicit

Sub MissingDims()
'Reviews Column "E" for blank cells (unreported values), Gets values from adjacent cells _
  and pastes to sheet4 Column J.
Dim rngBlanks As Range, rngCell As Range
Dim rngArea As Range
Dim rng As Range
Dim s As String

With Sheets("Sheet3")
    Set rngBlanks = .Range(.Cells(6, "E"), .Cells(.Rows.Count, "E") _
            .End(xlUp)).SpecialCells(xlCellTypeBlanks).Offset(, -4)End With

'Clear Cloum J on Sheet4, add header and format
Sheets("Sheet4").Range("J:J").Clear
Sheets("Sheet4").Range("J1").Value = "Missing Dims"
Sheets("Sheet4").Range("J:J").NumberFormat = "@"

For Each rngArea In rngBlanks.Areas
    With rngArea
        'Create string
        s = .Cells.Row & "     $$ #" & .Cells(1, 1) & ", " & .Cells(1, 2) _
                & ", " & .Cells(1, 4)
    End With
    'paste data
    Sheets("Sheet4").Cells(Rows.Count, "J") _
            .End(xlUp).Offset(1).Resize(rngArea.Rows.Count).Value = s
Next rngArea
Set rngBlanks = Nothing
End Sub

Attached is the workbook (Condensed), the macro above is omitted for security.
Sheets 1 and 2 have irrelavant data to this querry, sheet4 is where the new data is stored along with some preexisting data in columns A thru H. A small amount of data on sheet4 was left intact. Once the data from the macro is generated I move it to another wokbook and manually process information.

Any hints, tips or examples is appreciated.

Edit:
I think the code in Magenta may be causing me problems