Clever copy & Paste in Vb (or excel)

[ianuk1983]

Hello guys,

Wonder if anyone can help with this one. I have 2 rows one with account numbers the 2nd with mobile number.

i.e
Account Mobile Number
1234 071
1234 072
1234 073
4321 074

What I'm looking to do is paste them into one line. So all mobile numbers in one account

i.e

Account Mob1 Mob2 Mob3.....
1234 071 072 073

Is this possible do you think

Thanks?

 

[DiscoPistol]

Sorry but I'm only half following. Could you post an example of your worksheet?

DP

 

[Andrew Poulsom]

Try:

Sub Test()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim ShNew As Worksheet
    Dim First As Boolean
    Dim r As Long
    Dim c As Integer
    Dim Cell As Range
    Set Sh = Worksheets("Sheet1")
    Set Rng = Sh.Range("A1:A" & Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row)
    Set ShNew = Worksheets.Add
    First = True
    r = 1
    c = 2
    For Each Cell In Rng
        If Cell.Value = Cell.Offset(1, 0).Value Then
            If First Then
                ShNew.Cells(r, 1).Value = Cell.Value
                First = False
            End If
            ShNew.Cells(r, c).Value = Cell.Offset(0, 1).Value
            c = c + 1
        Else
            ShNew.Cells(r, c).Value = Cell.Offset(0, 1).Value
            First = True
            r = r + 1
            c = 2
        End If
    Next Cell
End Sub

 

[ianuk1983]

The code is amazing, the only problem is if there is only one mobile number that belongs to the account number it doesn't bring the account number onto the next sheet. just the mobile number. Would you know why?

Thank you very much for this

 

[Andrew Poulsom]

My code assumed there was always more than one entry, so let's try a different approach:

Sub Test()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim ShNew As Worksheet
    Dim r As Long
    Dim c As Integer
    Dim Cell As Range
    Set Sh = Worksheets("Sheet1")
    Set Rng = Sh.Range("A1:A" & Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row)
    Set ShNew = Worksheets.Add
    r = 1
    c = 2
    For Each Cell In Rng
        ShNew.Cells(r, c).Value = Cell.Offset(0, 1).Value
        With Rng
            If WorksheetFunction.CountIf(.Range(.Cells(Cell.Row, 1), .Cells(.Rows.Count, 1)), Cell.Value) = 1 Then
                ShNew.Cells(r, 1).Value = Cell.Value
                r = r + 1
                c = 2
            Else
                c = c + 1
            End If
        End With
    Next Cell
End Sub