Remove Blank Cells

[skillet]

This is probably not possible, I am on a Mac with multiple versions of MS Excel (including the latest version). I am trying to move the content of cells up into the blank cells based on a range of selection. I know I can

1. select a range and then
2. press F5 and
3. choose "Special..." and
4. choose the radial button "Blanks" and then
5. right click and right click and
6. choose delete
7. Select "Shift cells up" and
8. Press OK

However, I am not trying to delete cells just move the content of cells up so there is no blanks and they are all right next to each other. I have to do this with dozens of cells all the time daily and have been doing this for years but there has to be a better way.

 

[Fazza]

great

 

[skillet]

Okay Fazza, I really have no idea what I am doing and have really tried not to bother you again, I have changed positive values to negative values, less than to greater than, substituted words that look like they might change the right thing etc. but to no avail. Hopefully it is something simple but this is so nice is it possible to move them all down through empty cells basically the exact same thing as you did but down. If this takes more than a couple minutes don't worry about it I will keep pecking away seeing if I can figure it out. I apologize for asking for more help.

[FONT=Menlo]Sub FillEmptyCellsMoveSelectionUp()[/FONT][FONT=Menlo]
[/FONT]
[FONT=Menlo]
[/FONT]
[FONT=Menlo]    Dim i As Long, k As Long[/FONT]

[FONT=Menlo]    Application.ScreenUpdating = False[/FONT]

[FONT=Menlo]    With Selection[/FONT]
[FONT=Menlo]        For i = 1 To .Cells.Count[/FONT]
[FONT=Menlo]            If Len(.Cells(i).Value) > 0 Then[/FONT]
[FONT=Menlo]                k = k + -1[/FONT]
[FONT=Menlo]                If k < i Then[/FONT]
[FONT=Menlo]                    .Cells(i).Copy Destination:=.Cells(k)[/FONT]
[FONT=Menlo]                    .Cells(i).ClearContents[/FONT]
[FONT=Menlo]                End If[/FONT]
[FONT=Menlo]            End If[/FONT]
[FONT=Menlo]        Next i[/FONT]
[FONT=Menlo]    End With[/FONT]

[FONT=Menlo]End Sub[/FONT]

 

[Peter_SSs]

..is it possible to move them all down through empty cells basically the exact same thing as you did but down.

1. Is the layout the same as the previous file you provided?
2. Are you interested in the modification to my code to 'move down'?

 

[Fazza]

like this?

Sub movedown()

    Dim i As Long, k As Long
    
    Application.ScreenUpdating = False
    
    With Selection
        k = .Cells.Count + 1
        For i = .Cells.Count To 1 Step -1
            If Len(.Cells(i).Value) > 0 Then
                k = k - 1
                If k > i Then
                    .Cells(i).Copy Destination:=.Cells(k)
                    .Cells(i).ClearContents
                End If
            End If
        Next i
    End With
                
End Sub

 

[skillet]

like this?

Yes exactly like that, I never would have played around enough with it to come up with that. Very interesting to contrast and learn a little.

1. Is the layout the same as the previous file you provided?
2. Are you interested in the modification to my code to 'move down'?

The layout is the same, I'd love to see the contrast to learn from what it is doing, however I don't want you to spend too long on it since I won't need it as much as moving the selection down. Thank you both!

 

[Peter_SSs]

The layout is the same, I'd love to see the contrast to learn from what it is doing, however I don't want you to spend too long ..

To move down (for all your sections) the changes are pretty minimal (highlighted below).

Sub Move_Down()
  Dim rLength As Range, rVis As Range, rA As Range
  Dim sFirstAddr As String
  Dim k As Long
 
  Application.ScreenUpdating = False
  Set rLength = ActiveSheet.UsedRange.Find(What:="Length", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
  If Not rLength Is Nothing Then
    sFirstAddr = rLength.Address
    Do
      k = 0
      With rLength.Offset(, -1).Resize(rLength.Offset(, 1).End(xlDown).Row - rLength.Row + 1, 2)
        .AutoFilter Field:=2, Criteria1:="<>"
        Set rVis = .SpecialCells(xlVisible)
        ActiveSheet.AutoFilterMode = False
        For Each rA In rVis.Rows
          rA.Copy Destination:=.Rows(1).Offset(k)
          k = k + 1
        Next rA
        If k < .Rows.Count Then
          .Offset(k).Resize(.Rows.Count - k).ClearContents
          .Offset(1).Resize(k - 1).Copy Destination:=.Offset(.Rows.Count - k + 1)
          .Offset(1).Resize(k - 1).ClearContents
        End If
      End With
      Set rLength = ActiveSheet.UsedRange.FindNext(After:=rLength)
    Loop Until rLength.Address = sFirstAddr
  End If
  Application.ScreenUpdating = True
End Sub

 

[skillet]

That is pretty cool and shocking that can be done on an entire page while retaining formatting and the selection. I am so very thankful for smart people like you guys that are kind enough to help others out. Thank you! I hope to pass on the kindness to others in the few things that I know.

 

[Peter_SSs]

That is pretty cool and shocking that can be done on an entire page while retaining formatting and the selection. I am so very thankful for smart people like you guys that are kind enough to help others out. Thank you! I hope to pass on the kindness to others in the few things that I know.

Cheers. Glad to help.