Excel Macro to tighten cells in rows

Gatika · 05-21-2008, 09:45 AM

I've found this macro (here: http://en.allexperts.com/q/Excel-105...ty-cells-2.htm) which can tighten cells in rows (it moves all non-empty cells to the left, deleting blank cells). The problem is, it works on one row at a time. Is there a way to ask it to run through an entire worksheet, stopping when it reaches a blank cell in the first column? I don't want any cells moved up, just to the left.

Public Sub tighten_cells()

Dim row_or_col As Long
Dim xlR As Excel.Range
Dim xls As Excel.Worksheet
Dim xlr2 As Excel.Range

Dim i As Long, new_i As Long
Dim start_col As Long, start_row As Long, end_col As Long, end_row As Long

row_or_col = MsgBox("Press Yes for Row Tighten, No for Column Tighten, Cancel for Cancelling", vbYesNoCancel)

If row_or_col = vbCancel Then
Exit Sub
End If

Set xls = Excel.ActiveSheet
Set xlR = Excel.ActiveCell
Set xlr2 = xls.Cells.SpecialCells(xlCellTypeLastCell)

start_row = xlR.Row
start_col = xlR.Column

If (row_or_col = vbYes) Then ' Row Tighten -> move across columns
new_i = start_col
For i = start_col To xlr2.Column
If (xls.Cells(start_row, i) <> "") Then
If (new_i <> i) Then
xls.Cells(start_row, new_i) = xls.Cells(start_row, i)
xls.Cells(start_row, i) = ""
End If
new_i = new_i + 1
End If
Next i
End If

If (row_or_col = vbNo) Then ' Col Tighten -> move across rows
new_i = start_row
For i = start_row To xlr2.Row
If (xls.Cells(i, start_col) <> "") Then
If (new_i <> i) Then
xls.Cells(new_i, start_col) = xls.Cells(i, start_col)
xls.Cells(i, start_col) = ""
End If
new_i = new_i + 1
End If
Next i

End If

End Sub

David M58 · 05-21-2008, 03:46 PM

Here’s a suggestion that may help you get started. You could create another subroutine that uses a loop to repeatedly perform the tighten_cells() subroutine, running through the worksheet as you’ve described. Here’s some sample code.

Code:

Sub entire()
    Dim current_row As Long
    Dim acell As Excel.Range
    
    Do
        Set acell = Excel.ActiveCell
        If IsEmpty(acell) Then
            Exit Do
        End If
        
        tighten_cells
        
        If acell.Row < Excel.Rows.Count Then
            acell.Offset(1, 0).Select
        End If
    Loop Until acell.Row = Excel.Rows.Count
End Sub

To run this, you would place the cell pointer on a row where the cell in the first column contains data, and it will run until it reaches a blank cell in the first column, or until it runs out of rows. Modify as necessary.

Gatika · 05-21-2008, 07:39 PM

Wunderbar! It prompts me to run at every row, but that's better than nothing. :) And there are only about 65 rows.

Thanks very much!

05-21-2008, 09:45 AM	#1 (permalink)
Gatika Registered User Join Date: May 2008 Posts: 4 OS: XP	Excel Macro to tighten cells in rows I've found this macro (here: http://en.allexperts.com/q/Excel-105...ty-cells-2.htm) which can tighten cells in rows (it moves all non-empty cells to the left, deleting blank cells). The problem is, it works on one row at a time. Is there a way to ask it to run through an entire worksheet, stopping when it reaches a blank cell in the first column? I don't want any cells moved up, just to the left. Public Sub tighten_cells() Dim row_or_col As Long Dim xlR As Excel.Range Dim xls As Excel.Worksheet Dim xlr2 As Excel.Range Dim i As Long, new_i As Long Dim start_col As Long, start_row As Long, end_col As Long, end_row As Long row_or_col = MsgBox("Press Yes for Row Tighten, No for Column Tighten, Cancel for Cancelling", vbYesNoCancel) If row_or_col = vbCancel Then Exit Sub End If Set xls = Excel.ActiveSheet Set xlR = Excel.ActiveCell Set xlr2 = xls.Cells.SpecialCells(xlCellTypeLastCell) start_row = xlR.Row start_col = xlR.Column If (row_or_col = vbYes) Then ' Row Tighten -> move across columns new_i = start_col For i = start_col To xlr2.Column If (xls.Cells(start_row, i) <> "") Then If (new_i <> i) Then xls.Cells(start_row, new_i) = xls.Cells(start_row, i) xls.Cells(start_row, i) = "" End If new_i = new_i + 1 End If Next i End If If (row_or_col = vbNo) Then ' Col Tighten -> move across rows new_i = start_row For i = start_row To xlr2.Row If (xls.Cells(i, start_col) <> "") Then If (new_i <> i) Then xls.Cells(new_i, start_col) = xls.Cells(i, start_col) xls.Cells(i, start_col) = "" End If new_i = new_i + 1 End If Next i End If End Sub

05-21-2008, 03:46 PM	#2 (permalink)
David M58 Registered User Join Date: May 2008 Location: Baltimore, Maryland Posts: 160 OS: Windows XP SP3	Re: Excel Macro to tighten cells in rows Here’s a suggestion that may help you get started. You could create another subroutine that uses a loop to repeatedly perform the tighten_cells() subroutine, running through the worksheet as you’ve described. Here’s some sample code. Code: Sub entire() Dim current_row As Long Dim acell As Excel.Range Do Set acell = Excel.ActiveCell If IsEmpty(acell) Then Exit Do End If tighten_cells If acell.Row < Excel.Rows.Count Then acell.Offset(1, 0).Select End If Loop Until acell.Row = Excel.Rows.Count End Sub To run this, you would place the cell pointer on a row where the cell in the first column contains data, and it will run until it reaches a blank cell in the first column, or until it runs out of rows. Modify as necessary.

05-21-2008, 07:39 PM	#3 (permalink)
Gatika Registered User Join Date: May 2008 Posts: 4 OS: XP	Re: Excel Macro to tighten cells in rows Wunderbar! It prompts me to run at every row, but that's better than nothing. :) And there are only about 65 rows. Thanks very much!