Delete blank Cells With Partial Text Criteria

[Pilot5000]

sheet2 is very Explanatory , basically that is the format that I get the information every week , because I have some other work to-do with that information I am looking for macro that will transfer the information as I arrive to as it souled be (see attachment ) , moreover, just would like to mentioned that basically what i am looking for is that in every time I have the words {SELECT} and{CELL-ENTER} delete the only the blank cells under those rows form Column "A" to last column , basically s t the delete the blank and in those columns without moving the location of the data , thank you in advance for any help

 

[shrivallabha]

Tested lightly:

Adjust start row variable to suit your situation if needed.

Public Sub DelBlanks()
Dim lngStartRow As Long, lngLastCol As Long, lngLastRow As Long
lngStartRow = 6 '\\ Change this to suit
lngLastRow = Cells.Find("*", [A1], xlValues, xlWhole, xlByRows, xlPrevious).Row
lngLastCol = Cells.Find("*", [A1], xlValues, xlWhole, xlByColumns, xlPrevious).Column
Range(Cells(lngStartRow, 1), Cells(lngLastRow, lngLastCol)).SpecialCells(xlCellTypeBlanks).Delete xlUp
End Sub

 

[Luke M]

@shrivallabha
I too started down this approach, but notice that the data in col D has to stay lined up with it's corresponding data in col C. I wish I could do a line like:
Range("A6:A20").SpecialCells(xlCellTypeBlanks).Resize(1,2).Delete

but sadly, that's not allowed.

 

[Luke M]

A bit of an ugly approach, but this seems to create the right final layout.

Sub RemoveBlanks()
Dim myRange As Range
Dim i As Integer, rowSize As Integer
Dim xSh As Worksheet

'Define the used range somehow.
'for now, we'll just have you select all the data
Set myRange = Selection
'Could also use shivallabha's method to find the right range

rowSize = myRange.Rows.Count
Application.ScreenUpdating = False

'We use a temporary helper sheet to remove blank rows
Set xSh = ThisWorkbook.Worksheets.Add
With xSh
    For i = 1 To myRange.Columns.Count Step 2
        myRange.Columns(i).Resize(, 2).Copy .Cells(1, 1)
        .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete (xlUp)
        .Range("A1:B" & rowSize).Copy myRange.Columns(i).Resize(, 2)
    Next i
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
End Sub

 

[shrivallabha]

Whoops You are correct Luke.

Here's one more approach. I hope I get second time lucky.

Public Sub DelBlanks2()
Dim lngLastCol As Long, lngLastRow As Long
Dim r As Long
lngLastRow = Cells.Find("*", [A1], xlValues, xlWhole, xlByRows, xlPrevious).Row
lngLastCol = Cells.Find("*", [A1], xlValues, xlWhole, xlByColumns, xlPrevious).Column
Application.ScreenUpdating = False
For i = lngLastCol To 1 Step -1
  For j = lngLastRow To 1 Step -1
  If Trim(Cells(j, i).Value) Like "{SELECT *" And Len(Cells(j + 1, i).Value) = 0 Then
  Cells(j + 1, i).Resize(1, 2).Delete xlUp
  End If
  Next j
Next i
Application.ScreenUpdating = True
End Sub

 

[Pilot5000]

thank you guys you are Outstanding , I tried your macro it and it working beautiful . one more question,your macro is basically is a continuation for two other macros that come ahead , as you can see with the attached file , but when activate the macro sub "pilot_insert" (the first, that include the following macro "sub SeparateTest") in certain columns the name manager format of that column is change and not remain as it should(the way it's appear before we run the macro ) , in place other rows get the color format of the original name manager of that column, how I can change in my macro that it will remain the same , (I attached copy of the original data from sheet2 in sheet3 if you need it ) and my last question is there is there is a way to integrate those 3 macro in to one????

 

[Luke M]

The deleting of blanks can be easily integrated into the 2nd, and actually makes it a bit easier. Here's the two macros, revised to make them faster (better...stronger... )

Sub pilot_insert()
Dim l As Long
Dim myRow As Long
Application.ScreenUpdating = False

For l = Range("A1").SpecialCells(xlCellTypeLastCell).Column To 1 Step -1
    If Application.WorksheetFunction.CountA(Range(Cells(1, l), Cells(Rows.Count, l))) > 0 Then
        myRow = Cells(1, l).End(xlDown).Row
        'Do all the shifting in one shot
        If myRow > 2 Then Range(Cells(2, l), Cells(myRow - 1, l)).Delete (xlShiftUp)

        If l > 1 Then
            If Application.WorksheetFunction.CountA(Range(Cells(1, l - 1), Cells(Rows.Count, l - 1))) > 0 Then
                With Cells(1, l)
                    .EntireColumn.Insert
                    .Offset(, -1).EntireColumn.Interior.ColorIndex = -4142
                End With
            End If
        End If
    End If
Next l
SeparateTest
Application.ScreenUpdating = True

End Sub

Private Sub SeparateTest()
'This runs as a sub-servant to main macro
Dim rng As Range

Application.ScreenUpdating = False
With ActiveSheet

    For Each rng In .Cells.SpecialCells(xlCellTypeConstants)
   
        If InStr(rng.Value, "CELL-ENTER") Then
            'Cutting a cell physically moves it, so rng is not in same place
            rng.Cut rng.Offset(-1, 1)
            rng.Offset(1, -1).Resize(1, 2).Delete (xlShiftUp)
        'We use ElseIf since we don't need to check again if we found CELL-ENTER
        ElseIf InStr(rng.Value, "EDIT-CLEAR") Then
            rng.Cut rng.Offset(0, 1)
        End If
   
    Next rng

End With

Application.ScreenUpdating = True

End Sub

 

[Pilot5000]

thanks man you are great , what about your code is he can be integrate also here or just to call him ??? Moreover what about the my question regarding how can i keep the format of the cell copied with the same color format ????? , you don't know how much I appreciate your help, is there is a place in this site or another site that I can put some good words for your help to everyone ells to see ??? you deserve that

 

[Pilot5000]

luke I just tried your code and it work it doing everything I need ,please ignore the pervious questions I asked because I was too anxious to reply to your message , there for i wrote before I run your new version of the code , thank you thank you thank you , but still if there is place where I can put some good words let me know where I can do that