Consolidate Data Using VBA

[krwillhoit]

I am trying to consolidate data so that each loan type and amount for a given borrower / date combination is on the same row and then have the excess rows deleted.

Sample of Current Data:


Borrower
Date
Loan Type
Amount


A
12/15/2012
Term Loan A
22000000


A
12/15/2012
Term Loan B
17000000


A
12/15/2012
Revolver
9000000


A
12/15/2012
Letter of Credit
19000000


B
1/19/2013
Term Loan A
9000000


B
1/19/2013
Term Loan B
11000000


B
2/27/2013
Revolver
22000000


B
2/27/2013
Letter of Credit
84000000


C
7/5/2012
Term Loan A
23000000


C
7/5/2012
Term Loan B
48000000


D
8/15/2012
Term Loan B
67000000


D
8/15/2012
Revolver
1000000


D
9/10/2012
Term Loan A
55000000



Sample of Desired Outcome:



Borrower
Date
Loan Type
Amount
Loan Type 2
Amount 2
Loan Type 3
Amount 3
Loan Type 4
Amount 4


A
12/15/2012
Term Loan A
22000000
Term Loan B
17000000
Revolver
9000000
Letter of Credit
19000000


B
1/19/2013
Term Loan A
9000000
Term Loan B
11000000






B
2/27/2013
Revolver
22000000
Letter of Credit
84000000






C
7/5/2012
Term Loan A
23000000
Term Loan B
48000000






D
8/15/2012
Term Loan B
67000000
Revolver
1000000






D
9/10/2012
Term Loan A
55000000










Any help would be greatly appreciated.

Thank you,

[SamT]

Option Explicit


Sub Test()
Dim Cel As Range
Dim Col As Long
With ActiveSheet
For Each Cel In Range("A2:" & Cells(Rows.Count, 1).End(xlUp).Address)
Col = 5
If Cel.Offset(1, 0) = "" Then Exit Sub
Do While Cel = Cel.Offset(1, 0) And Cel.Offset(0, 1) = Cel.Offset(1, 1)
Cells(Cel.Row, Col) = Cel.Offset(1, 1)
Cells(Cel.Row, Col + 1) = Cel.Offset(1, 2)
Col = Col + 2
Rows(Cel.Row + 1).EntireRow.Delete
Loop
Next Cel
End With
End Sub

[krwillhoit]

Hi Sam,

Thank you for writing this for me. The script is working but it pulls the date and loan type for each unique pair rather than the loan type and amount. Can you please help me ammend it so the 3rd and 4th columns are added to the end rather then the 2nd and 3rd.

Thank you,
Kevin

[stanleydgrom]

krwillhoit,

Welcome to the VBA Express forum.

The following macro (a variation of SamT's macro) will do as you require, and, it will fill in the additional row 1 titles.

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).




Option Explicit
Sub ReorgData()
' stanleydgrom, 07/26/2013
' http://www.vbaexpress.com/forum/showthread.php?46942-Consolidate-Data-Using-VBA
Dim c As Range, lur As Long, nc As Long, lc As Long, luc As Long, i As Long, n As Long
Application.ScreenUpdating = False
With ActiveSheet
lc = .Cells(1, 1).End(xlToRight).Column
luc = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
lur = .Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
If luc > lc Then
.Range(.Cells(1, lc + 1), .Cells(lur, luc)).ClearContents
End If
For Each c In .Range("A2:" & .Cells(.Rows.Count, 1).End(xlUp).Address)
nc = 5
If c.Offset(1, 0) = "" Then GoTo DoTitles
Do While c = c.Offset(1, 0) And c.Offset(0, 1) = c.Offset(1, 1)
.Cells(c.Row, nc) = c.Offset(1, 2)
.Cells(c.Row, nc + 1) = c.Offset(1, 3)
nc = nc + 2
.Rows(c.Row + 1).EntireRow.Delete
Loop
Next c
DoTitles:
n = 1
luc = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
For i = 5 To luc - 1 Step 2
n = n + 1
.Cells(1, i) = "Loan Type " & n
.Cells(1, i + 1) = "Amount " & n
.Cells(1, i).Resize(, 2).Font.Bold = True
Next i
.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub



Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgData macro.

[SamT]

Option Explicit


Sub Test()
Dim Cel As Range
Dim Col As Long
With ActiveSheet
For Each Cel In Range("A2:" & Cells(Rows.Count, 1).End(xlUp).Address)
Col = 5
If Cel.Offset(1, 0) = "" Then Exit Sub
Do While Cel = Cel.Offset(1, 0) And Cel.Offset(0, 1) = Cel.Offset(1, 1)
Cells(Cel.Row, Col) = Cel.Offset(1, 3)
Cells(Cel.Row, Col + 1) = Cel.Offset(1, 4)
Col = Col + 2
Rows(Cel.Row + 1).EntireRow.Delete
Loop
Next Cel
End With
End Sub

[stanl]

As I understand it, the assumption is a consistent date for each account loan types. If this were to change, you might consider simply eliminating blank rows in the used range and creating a Pivot Table.

[krwillhoit]

Thank you for all the feedback.

Sam,

I used the new macro you wrote for me. I had to edit to:
Cells(Cel.Row, Col) = Cel.Offset(1, 2)
Cells(Cel.Row, Col + 1) = Cel.Offset(1, 3)
Not sure what that is if you could let me know for the future that would be great.

Again thank you for all the help.

[SamT]

Sub Test()

'Never use a VBA Keyword as a variable name
'Cel stands for Cell. A Range is a collection of 1 or more cells.
'Every Cell is also a Range. A Range collection of one.
'Cells is the collection of all cells in a given range. A single cell is
'refered to by Row index number and Column index number of the Cells collection.
'You can only get one cell at a time from the Cells collection.
Dim Cel As Range

'Col stands for Column. Columns are refered to by number
Dim Col As Long

'ActiveSheet is the sheet that would be seen if Excel was viewed.
'"With ActiveSheet" means the all the code until the End With, only
'the ActiveSheet will be efected/used.
With ActiveSheet

'In this next line, all the cells on the ActiveSheet is the Range the Cells
'collection belongs to.
'Rows is the collection of all the rows on the active sheet, so "Rows.Count"
'returns the number of rows which is the same as the number of the last row on
'the sheet.
'"Cells(Rows.Count, 1)" is the Cell or Range that is in the bottom row of the first column.
'"Range("A2:" & Cells(Rows.Count, 1)" is the same as "Range(A65536)"
'"(xlUp)" is a direction. In Excel this is like holding the Ctrl Key and tapping the Up Arrow.
'Other End directions work the same way in Excel.
'"Range(A65536).End(xlUp)" selects the bottom cell in column "A" that is not empty. The
'".Address" returns the address in "$A$1" notation. Adding all this together,
'This line gives the Range from A2 to the bottom most cell in column "A" that
'is not empty. "For Each Cel" in that range, do something.
For Each Cel In Range("A2:" & Cells(Rows.Count, 1).End(xlUp).Address)

Col = 5

'Range.Offset is a way to refer to a range by its position relative to the
'Range from which is Offset.
'Like the Cells collection, the Offset index is by row and column. Positive
'offsets refer to down and right, like adding row and column numbers.
'Negative offsets refer to up and left. 0 (zero) offsets refer to the same
'row or column.
'Cel.Offset(1, 0) refers to the cell just below Cel. ie; one row down in the
'same column.
'This line says that if the next cell in column A is empty, then we are done.
If Cel.Offset(1, 0) = "" Then Exit Sub
'Without that line, the "Next Cel" line at the bottom would make the code
'check all the newly empty rows, (because we deleted some rows,) in the original
'used range, and since "" = "", it would have copied all those blank cells
'to the columns starting at column(5) into the empty row below the new
'actual used range. It would raise an error if you had more duplicates than
'half the number of columns on the sheet.

'Cel is always a cell in Column "A".
'This line says that if the Borrower and Date in the row below are the same
'as in this row, then do something until they aren't the same.
Do While Cel = Cel.Offset(1, 0) And Cel.Offset(0, 1) = Cel.Offset(1, 1)

'Set the cell in Column(5) of this Row = the Loan Type of the Next row
Cells(Cel.Row, Col) = Cel.Offset(1, 2)

'Set Column(6) of this Row = the Amount of the next row'
Cells(Cel.Row, Col + 1) = Cel.Offset(1, 3)

'Just in case the next row we compare has the same Borrower and Date,
'set the "paste" column number to the next empty column of this row.
Col = Col + 2

'We have now "copied" the Type and Amount from the row below this row to
'the appropriate columns in this row, so delete the row below this row.
Rows(Cel.Row + 1).EntireRow.Delete

'Now go back up to the "Do While" line and check if the new "Row below this
'Row" has the same Borrower and Date. If it doesn't, then the "Do While"
'line will cause the code to jump to the line below this one.
Loop

'If we are here, then we have processed all the dulpicates below this row.
'This line, "Next Cel," tells the code to process the row below this row.
Next Cel


'We have processed all the rows and we're done with the ActiveSheet.
End With
End Sub