Individual record spans multiple rows

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

I have a huge excel file from a company that I am trying to print statements
from. There are hundreds of records for individuals that are formatted
something like this:

Name Charges
John Doe First Charge
Second Charge
Third Charge

How can I reformat these records so that they appear like this:

Name Charge1 Charge 2 Charge 3
John Doe First Charge Second Charge Third Charge

Any suggestions would be greatly appreciated. Thank You.
 
If the number of charges are always 3 then you can do the following:

Assuming that "First Charge" is in cell B2, then put '=B3' into C2 and
'=B3' into D2. This will result in the first record as in your example.
Now copy formulas of C2 and D2 down as needed.

Select the the whole table and copy / paste special (values) to get rid of
the formulas.

Sort the whole table by names. Delete all rows with empty names.

Cheers,

Joerg Mochikun
 
I suspect there are many names to be dealt with, and that they may not all
have same number of charges.

I'm thinking this code could help. Change the two Const values as needed
and test it on a copy of your workbook. It assumes that things are laid out
as in the example and not much else on the sheets.

Sub TransposeChargeData()
Const nameColumn = "A" ' change as needed
Const startRow = 2 ' row w/1st name in it
Dim lastNameRow As Long
Dim nameRow As Long
Dim rOffset As Long
Dim cOffset As Long
Dim baseCell As Range

If Val(Left(Application.Version, 2)) < 12 Then
'pre-2007 Excel
lastNameRow = Range(nameColumn & Rows.Count).End(xlUp).Row
Else
'Excel 2007 or later
lastNameRow = Range(nameColumn & Rows.CountLarge).End(xlUp).Row
End If
Set baseCell = Range(nameColumn & startRow)
Do Until rOffset > lastNameRow
If IsEmpty(baseCell.Offset(rOffset + 1, 0)) _
And Not (IsEmpty(baseCell.Offset(rOffset, 0))) Then
cOffset = 1 ' initialize/reset
Do Until IsEmpty(baseCell.Offset(rOffset + cOffset, 1))
baseCell.Offset(rOffset, cOffset + 1).Value = _
baseCell.Offset(rOffset + cOffset, 1).Value
baseCell.Offset(rOffset + cOffset, 1) = "" ' remove entry
cOffset = cOffset + 1 ' look for next charge
Loop
End If
rOffset = rOffset + 1 ' look for next name
Loop
End Sub
 
This is probably a dumb question, but where exactly do I put that code in my
workbook? Thank you so much for your help by the way.
 
Ignore that last post. I entered your code into VB editor in excel, and it
seemed to work, EXCEPT that it just pulled all of the charges up to the very
first name's row instead of seeing the next name and pulling that name's
charges up onto that row. Any suggestions?
 
I'll look at the code and try a different attack. I really didn't have
anything but the one sample to work from, and the code presumes there's an
empty row between the last charge for one person and the first charge for the
next. Sounds to me now as if there are no empty rows between first charge
for first person and last charge for last person.
 
Ok, this code presumes no empty rows between first charge for anyone and last
charge for anyone. It actually only changes one line of code, but the whole
thing is
here so you can just copy this and replace the existing routine easily. I
did add a statement: Application.ScreenUpdating = False that will improve the
speed for it. You won't see anything happening on the screen until the
process is completed, but this will get it all done much faster.

Sub TransposeChargeData()
Const nameColumn = "A" ' change as needed
Const startRow = 2 ' row w/1st name in it
Dim lastNameRow As Long
Dim nameRow As Long
Dim rOffset As Long
Dim cOffset As Long
Dim baseCell As Range

If Val(Left(Application.Version, 2)) < 12 Then
'pre-2007 Excel
lastNameRow = Range(nameColumn & Rows.Count).End(xlUp).Row
Else
'Excel 2007 or later
lastNameRow = Range(nameColumn & Rows.CountLarge).End(xlUp).Row
End If
Set baseCell = Range(nameColumn & startRow)
Application.ScreenUpdating = False ' improve performance
Do Until rOffset > lastNameRow
If IsEmpty(baseCell.Offset(rOffset + 1, 0)) _
And Not (IsEmpty(baseCell.Offset(rOffset, 0))) Then
cOffset = 1 ' initialize/reset
Do Until Not IsEmpty(baseCell.Offset(rOffset + cOffset, 0)) _
Or IsEmpty(baseCell.Offset(rOffset + cOffset, 1))
baseCell.Offset(rOffset, cOffset + 1).Value = _
baseCell.Offset(rOffset + cOffset, 1).Value
baseCell.Offset(rOffset + cOffset, 1) = "" ' remove entry
cOffset = cOffset + 1 ' look for next charge
Loop
End If
rOffset = rOffset + 1 ' look for next name
Loop
Application.ScreenUpdating = True
End Sub

If you want the process to actually physically delete the rows between the
names that had charges on them that were moved up to same row with names,
then use this code instead (same change as above, with delete rows function
added).

Sub TransposeChargeData()
Const nameColumn = "A" ' change as needed
Const startRow = 2 ' row w/1st name in it
Dim lastNameRow As Long
Dim nameRow As Long
Dim rOffset As Long
Dim cOffset As Long
Dim baseCell As Range
Dim TestRow As Long

If Val(Left(Application.Version, 2)) < 12 Then
'pre-2007 Excel
lastNameRow = Range(nameColumn & Rows.Count).End(xlUp).Row
Else
'Excel 2007 or later
lastNameRow = Range(nameColumn & Rows.CountLarge).End(xlUp).Row
End If
Set baseCell = Range(nameColumn & startRow)
Application.ScreenUpdating = False ' improve performance
Do Until rOffset > lastNameRow
If IsEmpty(baseCell.Offset(rOffset + 1, 0)) _
And Not (IsEmpty(baseCell.Offset(rOffset, 0))) Then
cOffset = 1 ' initialize/reset
Do Until Not IsEmpty(baseCell.Offset(rOffset + cOffset, 0)) _
Or IsEmpty(baseCell.Offset(rOffset + cOffset, 1))
baseCell.Offset(rOffset, cOffset + 1).Value = _
baseCell.Offset(rOffset + cOffset, 1).Value
baseCell.Offset(rOffset + cOffset, 1) = "" ' remove entry
cOffset = cOffset + 1 ' look for next charge
Loop
End If
rOffset = rOffset + 1 ' look for next name
Loop
'delete empty rows left behind
TestRow = lastNameRow
rOffset = 0 ' reset
Do Until baseCell.Offset(rOffset, 0).Row >= lastNameRow
'have to recalculate as we are deleting rows
lastNameRow = Range(nameColumn & TestRow).End(xlUp).Row
Do While IsEmpty(baseCell.Offset(rOffset, 0)) And _
baseCell.Offset(rOffset, 0).Row < _
Range(nameColumn & TestRow).End(xlUp).Row
baseCell.Offset(rOffset, 0).EntireRow.Delete
Loop
rOffset = rOffset + 1
Loop
Application.ScreenUpdating = True
End Sub
 
That worked. You rule. Thank you so much.

-Dana

JLatham said:
Ok, this code presumes no empty rows between first charge for anyone and last
charge for anyone. It actually only changes one line of code, but the whole
thing is
here so you can just copy this and replace the existing routine easily. I
did add a statement: Application.ScreenUpdating = False that will improve the
speed for it. You won't see anything happening on the screen until the
process is completed, but this will get it all done much faster.

Sub TransposeChargeData()
Const nameColumn = "A" ' change as needed
Const startRow = 2 ' row w/1st name in it
Dim lastNameRow As Long
Dim nameRow As Long
Dim rOffset As Long
Dim cOffset As Long
Dim baseCell As Range

If Val(Left(Application.Version, 2)) < 12 Then
'pre-2007 Excel
lastNameRow = Range(nameColumn & Rows.Count).End(xlUp).Row
Else
'Excel 2007 or later
lastNameRow = Range(nameColumn & Rows.CountLarge).End(xlUp).Row
End If
Set baseCell = Range(nameColumn & startRow)
Application.ScreenUpdating = False ' improve performance
Do Until rOffset > lastNameRow
If IsEmpty(baseCell.Offset(rOffset + 1, 0)) _
And Not (IsEmpty(baseCell.Offset(rOffset, 0))) Then
cOffset = 1 ' initialize/reset
Do Until Not IsEmpty(baseCell.Offset(rOffset + cOffset, 0)) _
Or IsEmpty(baseCell.Offset(rOffset + cOffset, 1))
baseCell.Offset(rOffset, cOffset + 1).Value = _
baseCell.Offset(rOffset + cOffset, 1).Value
baseCell.Offset(rOffset + cOffset, 1) = "" ' remove entry
cOffset = cOffset + 1 ' look for next charge
Loop
End If
rOffset = rOffset + 1 ' look for next name
Loop
Application.ScreenUpdating = True
End Sub

If you want the process to actually physically delete the rows between the
names that had charges on them that were moved up to same row with names,
then use this code instead (same change as above, with delete rows function
added).

Sub TransposeChargeData()
Const nameColumn = "A" ' change as needed
Const startRow = 2 ' row w/1st name in it
Dim lastNameRow As Long
Dim nameRow As Long
Dim rOffset As Long
Dim cOffset As Long
Dim baseCell As Range
Dim TestRow As Long

If Val(Left(Application.Version, 2)) < 12 Then
'pre-2007 Excel
lastNameRow = Range(nameColumn & Rows.Count).End(xlUp).Row
Else
'Excel 2007 or later
lastNameRow = Range(nameColumn & Rows.CountLarge).End(xlUp).Row
End If
Set baseCell = Range(nameColumn & startRow)
Application.ScreenUpdating = False ' improve performance
Do Until rOffset > lastNameRow
If IsEmpty(baseCell.Offset(rOffset + 1, 0)) _
And Not (IsEmpty(baseCell.Offset(rOffset, 0))) Then
cOffset = 1 ' initialize/reset
Do Until Not IsEmpty(baseCell.Offset(rOffset + cOffset, 0)) _
Or IsEmpty(baseCell.Offset(rOffset + cOffset, 1))
baseCell.Offset(rOffset, cOffset + 1).Value = _
baseCell.Offset(rOffset + cOffset, 1).Value
baseCell.Offset(rOffset + cOffset, 1) = "" ' remove entry
cOffset = cOffset + 1 ' look for next charge
Loop
End If
rOffset = rOffset + 1 ' look for next name
Loop
'delete empty rows left behind
TestRow = lastNameRow
rOffset = 0 ' reset
Do Until baseCell.Offset(rOffset, 0).Row >= lastNameRow
'have to recalculate as we are deleting rows
lastNameRow = Range(nameColumn & TestRow).End(xlUp).Row
Do While IsEmpty(baseCell.Offset(rOffset, 0)) And _
baseCell.Offset(rOffset, 0).Row < _
Range(nameColumn & TestRow).End(xlUp).Row
baseCell.Offset(rOffset, 0).EntireRow.Delete
Loop
rOffset = rOffset + 1
Loop
Application.ScreenUpdating = True
End Sub
Click to expand...
 
Back
Top