Results 1 to 10 of 10
  1. #1
    5 Star Lounger
    Join Date
    Jan 2001
    Posts
    1,119
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Need a macro (2000)

    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.

  2. #2
    3 Star Lounger
    Join Date
    Jan 2001
    Location
    Ankeny, Iowa, USA
    Posts
    298
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Need a macro (2000)

    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.

  3. #3
    3 Star Lounger
    Join Date
    Jan 2001
    Location
    Ankeny, Iowa, USA
    Posts
    298
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Need a macro (2000)

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

  4. #4
    5 Star Lounger
    Join Date
    Jan 2001
    Posts
    1,119
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Need a macro (2000)

    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.

  5. #5
    Uranium Lounger
    Join Date
    Jan 2001
    Location
    South Carolina, USA
    Posts
    7,295
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Need a macro (2000)

    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>
    Legare Coleman

  6. #6
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts

    Re: Need a macro (2000)

    (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.

  7. #7
    5 Star Lounger
    Join Date
    Jan 2001
    Posts
    1,119
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Need a macro (2000)

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

  8. #8
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts

    Re: Need a macro (2000)

    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

  9. #9
    Uranium Lounger
    Join Date
    Jan 2001
    Location
    South Carolina, USA
    Posts
    7,295
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Need a macro (2000)

    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>
    Legare Coleman

  10. #10
    5 Star Lounger
    Join Date
    Jan 2001
    Posts
    1,119
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Need a macro (2000)

    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •