VBA Help. Alignment of data

[arviy2k]

I have 5 columns of numerical data from Column L to P.
I use the SumIF function in column S to add all the negative numbers, if any.
I then use the IF function in Column R to add the loan # wherever negative values are present.

Here is a screenshot of what it looks like after I'm done with the above:

All I need to do is align this data and move it to the bottom, near the total. This is to make it look presentable and i'll know the defaulting loans at a glance.
I can move it manually, but there are over 50,000 loans and its time consuming.
So, I need a macro to do it, but I'm not sure how to code it.
Below is the screenshot of what it should look like:

Its basically just eliminating the blank cells. Can someone please help me out with the macro code for it?

here is the code i'm using for the SumIf.

Sub addadvances()
'
' addadvances Macro
'

'
    Do Until IsEmpty(ActiveCell.Offset(0, -3)) And IsEmpty(ActiveCell.Offset(1, -3))
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=SUMIF(RC[-7]:RC[-3],""<0"",RC[-7]:RC[-3])"
    ActiveCell.Copy
    ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveCell.Offset(1, 0).Select
    Loop
    ActiveCell.Offset(-1, 0).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.Replace what:="0", replacement:="", LookAt:=xlWhole, searchorder:=xlByRows
    Selection.Cells(1, 1).Select
    ActiveCell.Offset(0, -1).Select
    Application.CutCopyMode = False
    Do Until IsEmpty(ActiveCell.Offset(0, -3)) And IsEmpty(ActiveCell.Offset(1, -3))
    ActiveCell.FormulaR1C1 = "=if(rc[1]<0,rc[-12],"""")"
    ActiveCell.Copy
    ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveCell.Offset(1, 0).Select
    Loop
    
    
End Sub

I've got the addition part right. Just need the macro to delete the blank cells and put the data in one place..

Thanks in advance.
ArviY2k

 

[VoG]

Try this with a copy of your sheet

Sub test()
Dim LR As Long
Application.ScreenUpdating = False
LR = Range("Q" & Rows.Count).End(xlUp).Row
Columns("R:S").SpecialCells(xlCellTypeBlanks).Delete shift:=xlShiftUp
Do While Range("R" & LR - 1).Value = ""
    Range("R1:S1").Insert shift:=xlShiftDown
Loop
Application.ScreenUpdating = True
End Sub

 

[arviy2k]

Wow that worked perfectly. Thanks!!
However, just for my understanding, can you please explain the code if it isn't too much trouble? The code works, but I dont know how it works.

Also, there is an error at the following part of the original code. Excel seems to recognise even the blank cells of column R as having some data.

Do Until IsEmpty(ActiveCell.Offset(0, -3)) And IsEmpty(ActiveCell.Offset(1, -3))
    ActiveCell.FormulaR1C1 = "=if(rc[1]<0,rc[-12],"""")"
    ActiveCell.Copy
    ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveCell.Offset(1, 0).Select
    Loop

For example, even though there is nothing at Cell R7, {as per the screenshot}, excel doesnt consider it blank and hence doesn't delete the cell.

The code you provided only works if I use the following replacement:

Do Until IsEmpty(ActiveCell.Offset(0, -3)) And IsEmpty(ActiveCell.Offset(1, -3))
    ActiveCell.FormulaR1C1 = "=if(rc[1]<0,rc[-12])"
    ActiveCell.Copy
    ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveCell.Offset(1, 0).Select
    Loop
    ActiveCell.Offset(-1, 0).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.Replace what:="FALSE", replacement:="", LookAt:=xlWhole, searchorder:=xlByRows
    Selection.Cells(1, 1).Select

Any idea why this is happening? Sorry to bother you with all this beginner code but I'm just starting out with excel macros and don't know how to tackle errors yet..

Thanks for all your help.

Regards,
ArviY2k

 

[VoG]

Try this - it should work with cells containing ""

Dim LR As Long, i As Long
Application.ScreenUpdating = False
LR = Range("Q" & Rows.Count).End(xlUp).Row
For i = LR - 1 To 1 Step -1
    With Range("R" & i)
        If .Value = "" Then .Resize(, 2).Delete shift:=xlShiftUp
    End With
Next i
Do While Range("R" & LR - 1).Value = ""
    Range("R1:S1").Insert shift:=xlShiftDown
Loop
Application.ScreenUpdating = True

 

[arviy2k]

Just for the knowledge and to understand better, can you please explain the code? I guess it'll be helpful for others who have a similar situation.

I don't understand what's going on in the Do Loop and how its setting the data in the right place.

Try this with a copy of your sheet

Sub test()
Dim LR As Long
Application.ScreenUpdating = False
LR = Range("Q" & Rows.Count).End(xlUp).Row
Columns("R:S").SpecialCells(xlCellTypeBlanks).Delete shift:=xlShiftUp
Do While Range("R" & LR - 1).Value = ""
    Range("R1:S1").Insert shift:=xlShiftDown
Loop
Application.ScreenUpdating = True
End Sub

Thanks,
ArviY2k

 

[VoG]

I've added comments - hopefully this will help.

Dim LR As Long, i As Long
Application.ScreenUpdating = False ' turn off screen updating
LR = Range("Q" & Rows.Count).End(xlUp).Row ' find the last populated row in column Q
For i = LR - 1 To 1 Step -1 ' from that row to the top working backwards
    With Range("R" & i) ' if value in column R is ""
        If .Value = "" Then .Resize(, 2).Delete shift:=xlShiftUp 'delete blank R & S
    End With
Next i 'loop
'If you stop the code at this point you'll see that all the values in R and S are in contiguous rows starting in row 1
Do While Range("R" & LR - 1).Value = "" ' while the row above LR in column R is empty
    Range("R1:S1").Insert shift:=xlShiftDown ' push the values down by one row
Loop
Application.ScreenUpdating = True

 

[arviy2k]

That was really helpful.. This made my work so much easier.. Thank you so much.. !!


Regards,
ArviY2k

 

[Peter_SSs]

I haven't tested with 50,000 rows but I'd be interested to see how this goes for speed.

I have assumed that since you are moving the rows in cols R:S with the IF and SUMIF formulas, that you no longer require those formulas, just the results? My code also assumes there will always be some 'blank' rows in cols R:S. If not, a slight adjustment will be needed.

Anyway, once again test in a copy of your worksheet.

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> Compact()<br>    <SPAN style="color:#00007F">Dim</SPAN> rws <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>    <SPAN style="color:#00007F">With</SPAN> Range("Q4", Range("Q" & Rows.Count).End(xlUp)).Offset(, 1).Resize(, 2)<br>        .Value = .Value<br>         <SPAN style="color:#00007F">With</SPAN> .SpecialCells(xlCellTypeBlanks)<br>            rws = .Cells.Count / 2 - 1<br>            .Delete shift:=xlUp<br>         <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>         .Resize(rws).Insert shift:=xlDown<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[arviy2k]

Hi Peter,

Your code works just as well. It moved the cells a lot quicker actually.
You are right about the IF and SUMIF formulas, I copy and paste values within the macro. I dont need the formulas.

Your code seems to be quite similar to the one provided by VoG. If you could add comments to your code too, it would be very helpful. That way I'll be able to understand the code and not just the result. Thank you so much for your help.


Regards,
ArviY2k

Edit: By blank rows, if you mean blank cells within the range, I'm not sure about that. All the loans can have some negative values. But if you mean blank cells in the entire column, then its fine as my data doesn't hit the bottom of the worksheet.

 

[Peter_SSs]

It moved the cells a lot quicker actually.

It should be quicker since it works with blocks of data rather than looping a row at a time. Looping is generally a relatively slow vba process.

If you could add comments to your code too, it would be very helpful. That way I'll be able to understand the code and not just the result. Thank you so much for your help.

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> Compact()<br>    <SPAN style="color:#00007F">Dim</SPAN> rws <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>    <br>    <SPAN style="color:#007F00">'Start with range from Q4 to the end of the col Q data</SPAN><br>    <SPAN style="color:#007F00">'then move right 3 columns and resize to 2 columns wide</SPAN><br>    <SPAN style="color:#007F00">' This gives the range from R4:S(end of col Q data)</SPAN><br>    <SPAN style="color:#00007F">With</SPAN> Range("Q4", Range("Q" & Rows.Count).End(xlUp)).Offset(, 1).Resize(, 2)<br>    <br>        <SPAN style="color:#007F00">'Replace your IF & SUMIF formulas with their resulting values</SPAN><br>        <SPAN style="color:#007F00">'this will save time if the sheet needs to recalculate</SPAN><br>        .Value = .Value<br>        <br>        <SPAN style="color:#007F00">'Now work with just the blank cells in the col R:S range</SPAN><br>         <SPAN style="color:#00007F">With</SPAN> .SpecialCells(xlCellTypeBlanks)<br>         <br>            <SPAN style="color:#007F00">'Count the number of blank rows (count the blank cells and divide by 2)</SPAN><br>            <SPAN style="color:#007F00">'and subtract 1 (because of your 'Total' row)</SPAN><br>            rws = .Cells.Count / 2 - 1<br>            <br>            <SPAN style="color:#007F00">'Now delete blanks & shift</SPAN><br>            .Delete shift:=xlUp<br>         <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>         <br>         <SPAN style="color:#007F00">'Because we counted the blank rows earlier, we know how many rows</SPAN><br>         <SPAN style="color:#007F00">'we deleted and so we know how many blank rows to add back in</SPAN><br>         <SPAN style="color:#007F00">'at the top, thereby shifting our results down to the correct spot</SPAN><br>         .Resize(rws).Insert shift:=xlDown<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

Edit: By blank rows, if you mean blank cells within the range, I'm not sure about that. All the loans can have some negative values. But if you mean blank cells in the entire column, then its fine as my data doesn't hit the bottom of the worksheet.

I did mean if all the loans could have negative values then an adjustment would be needed.

However, on further thought I don't think an adjustment is needed. My code will error if there are no blank cells in the range R4:S(end of col Q data) but I believe that R4:S4 will always be blank(?). If so, no adjustment will be required.