VBA to move rows of data up removing blank rows.

[dbmathis]

Hi all,

I have the following senario.

Transaction Register Starting Dec-16-2005 Draft.xls
	K	L	M	N
10	Desciprion		Amount
11	#121 Tags		$177.64	0
12	#123 Truck		$279.89	0
13	#122 Emmy's Car		$280.00	0
14				0
15				0
16	Burger King		$6.90	0
17				0
18				0
19				0
20				0
21				0
22				0
23				0
24	St.Albert		$5.00	0
25	HEB		$49.06	0
26				0
27				0
28				0
29				0
30				0
31				0
Transaction Register

Due to the limitations of space on this forum I am only showing K11:M31 but my actual sheet has an area of K11:M41.

Does anyone know how to do the following with VBA? Basically move all blank lines to the bottom of the K11:M41 and move all rows that contain data to the top of the area?

The location of the rows of data within the area of K11:K41 varies from day to day depending on what's deleted, which is what creates these blank lines between data.

For example the end result would be:

Transaction Register Starting Dec-16-2005 Draft.xls
	K	L	M	N
10	Desciprion		Amount
11	#121 Tags		$177.64	0
12	#123 Truck		$279.89	0
13	#122 Emmy's Car		$280.00	0
14	Burger King		$6.90	0
15	St.Albert		$5.00	0
16	HEB		$49.06	0
17				0
18				0
Transaction Register

Thanks.

 

[jindon]

try
sub test()
dim r as range,a(),i as long
for each r in range("K11:K41")
if isempty(r) then
i=i+1:redim preserve a(1 to 2,1 to i)
a(1,i)=r.value
a(2,i)=r.offset(,1).value
end if
next
range("K11:M41").clearcontents
range("K11").resize(ubound(a,2),ubound(a,1))=application.transpose(a)
erase a
end sub

 

[dbmathis]

That seemed to partially delete the data in the upper column K. It didn't remove any blanks.

bbiab. Wife is calling me

Thanks for your help btw.

 

[jindon]

OOps!

it should read as

if not isempty(r) then

sub test()
dim r as range,a(),i as long
for each r in range("K11:K41")
if not isempty(r) then
i=i+1:redim preserve a(1 to 3,1 to i)
a(1,i)=r.value
a(2,i)=r.offset(,1).value
a(3,i)=r.offset(,2).value
end if
next
range("K11:M41").clearcontents
range("K11").resize(ubound(a,2),ubound(a,1))=application.transpose(a)
erase a
end sub

 

[Mark O'Brien]

I'm assuming that you have some data below the target range that you do not want to disturb. That is why you do not want to simply delete cells.

That being the case. Something like this should work:

Public Sub main()

  Dim oRange As Range
  
  Set oRange = Worksheets("Sheet1").Range("K12:M41")
  MoveData oRange
  
End Sub

Public Sub MoveData(ByRef oRange As Range)
  Dim i As Integer
  Dim j As Integer
  
  For i = 1 To oRange.Rows.Count
    If oRange.Value2(i, 1) = "" Then
      If Intersect(oRange, oRange(i, 1).End(xlDown)) Is Nothing Then Exit Sub
        For j = 1 To 3 Step 2
          oRange(i, j).Value = oRange(i, j).End(xlDown).Value
          oRange(i, j).End(xlDown).Value = ""
        Next
    End If
  Next
  
End Sub

 

[dbmathis]

Thanks Mark and jindon got it working because of you two. Much appreciated.

Have a Merry Christmas!

 

[dbmathis]

Mark,

Found a problem with the code you posted and don't seem to be able to figure out the solution. The following have a blank line above them and when I run the VBA it outputs the following.

Before:

Blank line
#123 Truck $279.89
#122 Emmy's Car $280.00

After:

#123 Truck $279.89
#123 Truck $279.89

These two screenshots should better describe the issue.

Before:

After:

Thanks for all your help.[/img]

 

[Mark O'Brien]

Are you still in the same range? K11:M41?

EDIT:: Never mind. I think I see the problem.

 

[dbmathis]

I am in range K11:K31 now. Sorry I didn't mention this, it didn't look like it effected the code, I just modified the range in the code to match the area on my sheet, but it wasn't working right when I had it set to K12:M41 either.

My Bad. Hope this helps.

 

[Mark O'Brien]

I think this fixes the problem:

Public Sub main()

  Dim oRange As Range
  
  Set oRange = Worksheets("Sheet1").Range("K12:M41")
  MoveData oRange
  
End Sub

Public Sub MoveData(ByRef oRange As Range)
  Dim i As Integer
  Dim j As Integer
  Dim oMoveRange As Range
  
  For i = 1 To oRange.Rows.Count
    If oRange.Value2(i, 1) = "" Then
      Set oMoveRange = oRange(i, 1).End(xlDown)
      If Intersect(oRange, oMoveRange) Is Nothing Then Exit Sub
        For j = 0 To 2 Step 2
          oRange(i, j + 1).Value = oMoveRange.Offset(0, j).Value
          oMoveRange.Offset(0, j).Value = ""
        Next
    End If
  Next
  
End Sub

 

[dbmathis]

Seems to be working like a champ. THANK YOU!

I will go study that code now.

Merry Christmas.