Macro to transpose based on value

[Nooblet]

Hi all,

I have 2 columns of data - the first is a customer number, the second is a quantity, but can also be text where there is no quantity.

I want to clean up the data by transposing all of the values for each customer number into one row and then delete empty rows, but am having trouble finding and/or figuring out the macro for it.


Basically I want the data to go from this:

12345678 60
12345678 63
12345678 74
12345678 71
12345678 70
12345678 68
21212121 75
21212121 73
21212121 66
21212121 W(0)
12121212 70
34343434 W(0)
34343434 W(0)
34343434 W(0)
34343434 82

To this:

12345678 60 63 74 71 70 68
21212121 75 73 66 W(0)
12121212 70
34343434 W(0) W(0) W(0) 82

I need to do this for more than one worksheet, the amount of data varies and the number of orders/quantities per customer can vary. Data is sorted by customer number (Column A), Column B is the quantities.

Any help would be much appreciated.

 

[Andrew Poulsom]

Try:

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 Cell.Value <> Cell.Offset(1, 0).Value 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

Change the sheet reference if necessary.

 

[Nooblet]

Thanks for the help - I'm no longer at work but will give it a try first thing in the morning.

 

[Yahya]

Nooblet
another way by formula
In E2 use this array Formula
=IFERROR(INDEX($A$2:$A$16,MATCH(0,COUNTIF($E$1:E1,$A$2:$A$16),0)),"")
copy it down

in F2
=IFERROR(INDEX($B$2:$B$16,SMALL(IF($A$2:$A$16=$E2,ROW($A$2:$A$16)-ROW($A$2)+1),COLUMN(A:A))),"")

copy it right and down

array Formula must enter by Ctrl+Shift+Enter

HTH

 

[Armando Montes]

Try...

Sub Rows2Cols()
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = LR To 2 Step -1
   With Range("A" & i)
       If .Value <> .Offset(-1).Value Then Rows(i).Insert
   End With
Next i
For Each Area In Columns("B").SpecialCells(xlCellTypeConstants).Areas
   Area(1).Offset(, 1).Resize(, Area.Rows.Count).Value = Application.Transpose(Area)
Next Area
Columns("C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Columns("B").Delete
Application.ScreenUpdating = True
End Sub

 

[Nooblet]

I have had a chance to try out all of the above and, although all three options work, ultimately the macros are a lot faster and easier to use.

I need to do this same action on multiple sheets with different amounts of data (thousands of rows) and up to 20 separate quantitites for each customer, so the array formula starts becoming a bit too laborious compared to the macros.

Thank you to all of you for your help!

 

[thefirstone]

Hi, that worked great except my database is over 7 million records so I had to break up the text file and so I now have 8 workbooks. I know I can run the script on each workbook but is there a way to have the first workbook
be the master and then look at the other workbooks and add the data to more columns.

Tim

 

[khalidness]

Need a macro to transpose single row into columns based on value....

My data :


|A
B
C
D
E
|F
G
H
|I
|J
K
L
M
N
|O
P


Expected Data


|A B C D E
|F G H
|I
|J K L M N
|0 P


I need a macro to transpose rows into columns.
Whenever the cell has pipe "|" (e.g. |A, |F..) data should be entered in next row.


I have a macro that will transpose a row for every 7 rows, but I need macro that transposes till cell has "|" in one row and then continue to next row.


Sub test()
Dim rng As Range, m As Integer, c As Range
Columns("C:I").Delete
m = 7
Set rng = Range(Range("a1"), Range("a1").End(xlDown))
Set c = Range("a1")
Do While c <> ""
'MsgBox c.Address


Range(c, c.Offset(m - 1, 0)).Copy
Cells(Rows.Count, "c").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Set c = c.Offset(m, 0)
Loop


End Sub


Kindly do the needful.