I need VBA Help for Excel spreadsheet -- Please!

[ILoveMyCorgi]

I have an Excel spreadsheet with three columns: ColA has a student number,
ColB has a comment, and ColC has an amount. I have many rows of different
comments and amounts for the same student number followed by rows with new
student numbers and so on. I need to move all of columns B and columns C to
the same row of the first line for the student number and move on to the next
student number. What I am trying to do is have all the data for one student
on one row so that I can merge the data with a Word document.

For instance,
1495 writing in book $10.00
1495 football trans $ 5.00
3456 Water damage $15.00
3456 Lost Textbook $35.00

Witn an outcome of:
1495 writing in book $10.00 football trans $5.00
3456 Water damage $15.00 Lost Textbook $35.00

I hope someone can help me with this. Thak you.

 

[Rich Locus]

Dear Excel Member:
If this solves your problem, please give me credit and check the "Answer"
box. Here's a solution that I tested. You may need to change the data type
for student (I chose string), but other than that, I believe it does what you
need.

Option Explicit
Option Base 1

Public Sub CombineRows()
Dim intLastRowColumnA As Long
Dim intStartingRow As Long
Dim intNextColumnForSameStudent As Long
Dim intCurrentActiveRowForStudent As Long
Dim strLastStudentNumber As String
Dim i As Long
Dim j As Long

intLastRowColumnA = Cells(Rows.Count, "A").End(xlUp).Row
intStartingRow = 2
intNextColumnForSameStudent = 3
intCurrentActiveRowForStudent = intStartingRow

strLastStudentNumber = Cells(intStartingRow, 1).Value

For i = intStartingRow + 1 To intLastRowColumnA
If strLastStudentNumber = Cells(i, 1).Value Then
intNextColumnForSameStudent = intNextColumnForSameStudent + 1
Cells(intCurrentActiveRowForStudent,
intNextColumnForSameStudent).Value = Cells(i, 2)
intNextColumnForSameStudent = intNextColumnForSameStudent + 1
Cells(intCurrentActiveRowForStudent,
intNextColumnForSameStudent).Value = Cells(i, 3)
Else
intNextColumnForSameStudent = 3
intCurrentActiveRowForStudent = intCurrentActiveRowForStudent + 1
Cells(intCurrentActiveRowForStudent, 1).Value = Cells(i, 1).Value
Cells(intCurrentActiveRowForStudent, 2).Value = Cells(i, 2).Value
Cells(intCurrentActiveRowForStudent, 3).Value = Cells(i, 3).Value
strLastStudentNumber = Cells(i, 1).Value
End If
Next i

For j = intLastRowColumnA To intCurrentActiveRowForStudent + 1 Step -1
Rows(j).Delete
Next j

End Sub

 

[Rich Locus]

I also made two other assumptions:
1) The data in the spreadsheet is sorted by Column A
2) Student data starts in row 2

If the student data starts in a different row, you can change the program.
The data, however, must be sorted.

 

[ILoveMyCorgi]

You assumed correct. When I ran the code, I got compile error: Syntax error
and stops at Cells(intCurrentActiveRowForStudent, When I scroll up, Public
Sub CombineRows() is highlighted in yellow... I am new to do this so I am not
sure what I need to do. Thank you for your help.

 

[Rich Locus]

Hello:
I actually ran the code on Excel 2003 and it worked fine. Copy the code,
then go to the VBA area by selecting ALT-F11.

Then select Insert, Module from the menu. Highlight everything in the
module (probably only one line) and then paste what you copied.

Then from the Debug menu, you can select "Compile VBA Project.

If you are still having problems, shoot me an email to (e-mail address removed) and
I will send you a working version in which you can copy and past all your
spreadsheet data.

 

[Jim Berglund]

This works - make sure your data is in 3 columns, starting in Cell A1
Jim Berglund

Sub Concatenate()
Dim i, j, n, p As Integer

i = 2
n = 2
p = 2

Cells(i, 4).Value = Cells(i, 1).Value
ActiveSheet.Range("A1").Select
j = ActiveCell.CurrentRegion.Rows.Count

For i = 2 To j
While Cells(i, 1).Value = Cells(p, 4).Value
Cells(n, 5).Value = (Cells(n, 5).Value & ", " & Cells(i, 2).Value) & "
$" & Cells(i, 3).Value
Cells(n, 6).Value = Cells(n, 6).Value + Cells(i, 3).Value
i = i + 1

Wend
p = p + 1
n = n + 1
Cells(p, 4).Value = Cells(i, 1).Value
i = i - 1
Next

End Sub

 

[Rich Locus]

I found your problem. When you copied and pasted the program, it broke up
some of the longer lines into two separate lines, which is a no-no unless you
use the "underscore" continuation character.

Notice that you have two groups of "2 lines" that are red. Each of those
groups should be one continuous line that is not broken into two. That will
fix your issue, and PLEASE check that this is the answer when it works.

 

[Rich Locus]

Jim:

Pretty nifty approach. It worked well except that the notes in column b for
the very first row didn't get copied. Cool concatenation code!! I will add
this to my library of examples.

 

[JLGWhiz]

Make a copy of your sheet and try this code on it. It seems to work, but to
be safe, it is better to test it first.

Sub stuFee()
Dim sh As Worksheet, lr As Long, rng As Range
Dim c As Range, f As Range
Set sh = ActiveSheet
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh.Range("A2:A" & lr)

For Each c In rng
sNum = c.Value
With rng
Set f = .Find(sNum, LookIn:=xlValues)
If Not f Is Nothing Then
fAddr = c.Address
Do
If f.Address <> c.Address Then
lc = sh.Cells(c.Row, Columns.Count).End(xlToLeft).Column
f.Offset(0, 1).Resize(1, 2).Copy sh.Cells(c.Row, lc + 1)
Rows(f.Row).Delete
End If
Set f = .FindNext(c)

Loop While Not c Is Nothing And f.Address <> fAddr
End If
End With
Next
End Sub

 

[JLGWhiz]

Just noticed that a couple of lines are long enough to cause line wrap.
This should paste into the code window better.

Sub stuFee()
Dim sh As Worksheet, lr As Long, rng As Range
Dim c As Range, f As Range
Set sh = ActiveSheet
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh.Range("A2:A" & lr)
For Each c In rng
sNum = c.Value
With rng
Set f = .Find(sNum, LookIn:=xlValues)
If Not f Is Nothing Then
fAddr = c.Address
Do
If f.Address <> c.Address Then
lc = sh.Cells(c.Row, Columns. _
Count).End(xlToLeft).Column
f.Offset(0, 1).Resize(1, 2). _
Copy sh.Cells(c.Row, lc + 1)
Rows(f.Row).Delete
End If
Set f = .FindNext(c)
Loop While Not c Is Nothing And _
f.Address <> fAddr
End If
End With
Next
End Sub

 

[Ron Rosenfeld]

I have an Excel spreadsheet with three columns: ColA has a student number,
ColB has a comment, and ColC has an amount. I have many rows of different
comments and amounts for the same student number followed by rows with new
student numbers and so on. I need to move all of columns B and columns C to
the same row of the first line for the student number and move on to the next
student number. What I am trying to do is have all the data for one student
on one row so that I can merge the data with a Word document.

For instance,
1495 writing in book $10.00
1495 football trans $ 5.00
3456 Water damage $15.00
3456 Lost Textbook $35.00

Witn an outcome of:
1495 writing in book $10.00 football trans $5.00
3456 Water damage $15.00 Lost Textbook $35.00

I hope someone can help me with this. Thak you.

It is not clear to me whether you want the data for each student in different
cells in the same row, or all the data concatenated into one cell.

I assumed that you wanted the data in separate cells. In other words:

1495 | writing in book | $10.00 | football trans | $5.00
3456 | water damage | $15.00 | Lost Textbook | $35.00

etc.

If you want it all concatenated, that is a simple change, but you need to
indicate how you want the different segments delimited.

Additional Assumptions:
The data is in columns A:C
No blanks in the student number column.
If there is a header row at the top, the header is non-numeric.
The data is not sorted.
The results of the operation will start in Column E.


The number of pairs of comments/amounts for each student is limited by the
number of columns in your version of Excel (approx 120 or 8000, depending on
the version).

To enter this Macro (Sub), <alt-F11> opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and
paste the code below into the window that opens.

To use this Macro (Sub), <alt-F8> opens the macro dialog box. Select the macro
by name, and <RUN>.

=======================================
Option Explicit
Sub Combine()
Dim rSrc As Range, c As Range
Dim rDest As Range
Dim cStudNum As New Collection
Dim sFirstAddress As String
Dim i As Long, j As Long

Set rSrc = Cells(Rows.Count, 1).End(xlUp)
'Assume no blanks in column a
Set rSrc = Range(rSrc.End(xlUp), rSrc)

'where should output be?
Set rDest = Cells(2, 5)

'test for a headers row by seeing if rg(1,1) is numeric
If Not IsNumeric(rSrc(1, 1).Value) Then
Set rSrc = rSrc.Offset(1, 0).Resize(Rowsize:=rSrc.Rows.Count - 1)
End If

'Get unique list of student nums
On Error Resume Next
For Each c In rSrc
cStudNum.Add Item:=c.Text, Key:=c.Text
Next c
On Error GoTo 0

'Output strings
For i = 1 To cStudNum.Count
j = 1
Set c = rSrc.Find(What:=cStudNum(i), After:=rSrc(rSrc.Rows.Count, 1), _
LookIn:=xlValues, lookat:=xlWhole)
sFirstAddress = c.Address
rDest(i, 1).Value = c.Value
Do
rDest(i, 2 * j).Value = c(1, 2).Value
rDest(i, 2 * j + 1).Value = c(1, 3).Value
j = j + 1
Set c = rSrc.FindNext(c)
Loop While c.Address <> sFirstAddress
Next i
End Sub
===========================================

--ron