Need a macro (2000)

[LindaR]

I have a spreadsheet that has client numbers. For each client number there are alpabet letters that are in different rows (see attached). What I want to do is move the letters up so they are in one row. Sometimes the letter or letters are in the same row but sometimes they are not. I am moving them manually right now but there are over a 1000 client numbers to do this for. Would a macro be able to do this? Thanks for any help you can provide.

[BAN]

could you fill in the blanks with one of the methods from <post#=460,022>post 460,022</post: > and then concatenate the row data and sort on the concatenated value?

Example attached.

[BAN]

Oops, I read this again and I think I misunderstood what you were after. Sorry.

[LindaR]

Thanks for the reply. What I need is to have each client number to have all the letters on the same line. Each client number is unique so everything before the next client number should be in the same row. I made a mistake on one of the rows where there is an A and a C. There should be a B on a separte line and a C on a separate line. I just wanted to show that there are different scenarios. Sometimes there could be just an A. Sometimes there could be A, B on different lines and sometimes A,B,C,D on different lines.

[LegareColeman]

Does this do what you need?

<code>
Public Sub CombineRows()
Dim I As Long, J As Long, lLast As Long
I = 0
Do While True
If Range("A1").Offset(I + 1, 0).Value <> "" Then
I = I + 1
Else
lLast = Range("IV1").Offset(I + 1, 0).End(xlToLeft).Column - 1
If lLast < 1 Then Exit Do
For J = 1 To lLast
Range("A1").Offset(I, J).Value = Range("A1").Offset(I, J).Value & Range("A1").Offset(I + 1, J).Value
Next J
Range("A1").Offset(I + 1, 0).EntireRow.Delete
End If
Loop
End Sub
</code>

[HansV]

(Added: Legare's solution is a lot shorter!)

Try this:

Sub CombineRows()
Dim lngMaxRow As Long
Dim lngMaxCol As Long
Dim lngPrevRow As Long
Dim lngRow As Long
Dim lngCol As Long
Dim rngFind As Range
lngMaxRow = Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row
lngPrevRow = lngMaxRow
lngMaxCol = Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column
For lngRow = lngMaxRow To 1 Step -1
If Cells(lngRow, 1) <> "" Then
If lngPrevRow > lngRow Then
For lngCol = 2 To lngMaxCol
Set rngFind = Range(Cells(lngRow, lngCol), _
Cells(lngPrevRow, lngCol)).Find(What:="?")
If Not rngFind Is Nothing Then
Cells(lngRow, lngCol) = rngFind.Value
End If
Next lngCol
' Next line is optional: delete rows with blanks in column A.
Range((lngRow + 1) & ":" & lngPrevRow).Delete
End If
lngPrevRow = lngRow - 1
End If
Next lngRow
End Sub

You can comment out the line marked as optional if you don't want to remove the rows with blanks in column A.

[LindaR]

I may have oversimplified the spreadsheet. Attached is part of the real spreadsheet.

[HansV]

Does this slightly modified version of my code do what you want (I only made it start in column B instead of column A):

Sub CombineRows()
Dim lngMaxRow As Long
Dim lngMaxCol As Long
Dim lngPrevRow As Long
Dim lngRow As Long
Dim lngCol As Long
Dim rngFind As Range
lngMaxRow = Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row
lngPrevRow = lngMaxRow
lngMaxCol = Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column
For lngRow = lngMaxRow To 1 Step -1
If Cells(lngRow, 2) <> "" Then
If lngPrevRow > lngRow Then
For lngCol = 3 To lngMaxCol
Set rngFind = Range(Cells(lngRow, lngCol), _
Cells(lngPrevRow, lngCol)).Find(What:="?")
If Not rngFind Is Nothing Then
Cells(lngRow, lngCol) = rngFind.Value
End If
Next lngCol
' Next line is optional: delete rows with blanks in column B.
Range((lngRow + 1) & ":" & lngPrevRow).Delete
End If
lngPrevRow = lngRow - 1
End If
Next lngRow
End Sub

[LegareColeman]

Here is a modified version of my code (which I think is still simpler than Hans' <img src=/S/grin.gif border=0 alt=grin width=15 height=15>)

<code>
Public Sub CombineRows()
Dim I As Long, J As Long, lLast As Long, lMaxRow As Long
I = 0
Do While True
If Range("B1").Offset(I + 1, 0).Value <> "" Then
I = I + 1
Else
lLast = Range("IV1").Offset(I + 1, 0).End(xlToLeft).Column - 1
If lLast < 3 And Range("B1").Offset(I + 2, 0).Value = "" Then Exit Do
For J = 3 To lLast
Range("A1").Offset(I, J).Value = Range("A1").Offset(I, J).Value & Range("A1").Offset(I + 1, J).Value
Next J
Range("A1").Offset(I + 1, 0).EntireRow.Delete
End If
Loop
End Sub
</code>

[LindaR]

Thank you both for taking the time to do this. The one from Hans worked. I don't know why Legare's didn't - maybe I did something wrong. Thank you - you saved me a lot of time and frustration.