Rearranging data based on counter using VBA code

[parag141]

Hi everyone,

I have long list of data in following format, and for the better usage of data I need to rearrange these into item 1, value 1, purchase price 1, item 2, value 2, Purchase price 2 item3, etc format, I

Can you please tell me a macro code to achieve this.


Currently data in following format:





Reference number
Item
Value
Pur price


00000012B01
Iphone
500
4464


00000012B01
Galaxy
630
671


00000012B01
Tab
4960
624


00000012B05
Laptop
693
567


00000012B05
Gun
60
450


00000012B05
Pen
3
405


00000012B05
PDA
30
289


00000012B05
Book
40
289


00000012B08
Laptop
321
289


00000012B08
Trophy
450
58


00000012B08
Car
64
54


00000012B09
Van
46
41


00000012B09
Bus
321
36


00000012B09
Marker
746
27


00000012B09
Board
321
3




trying to rearrange in following format:


Reference num
Item1
Value1
Pur Price1
Item2
Value2
Pur Price2
Item3
Value3
Pur Price3
Item4
Value4
Pur Price4
Item5
Value5
Pur Price5


00000012B01
Iphone
500
4464
Galaxy
630
671
Tab
4960
624








00000012B05
Laptop
693
567
Gun
60
450
Pen
3
405
PDA
30
289
Book
40
289


00000012B08
Laptop
321
289
Trophy
450
58
Car
64
54








00000012B09
Van
46
41
Bus
321
36
Marker
746
27
Board
321
3

[jolivanes]

Try this on a copy of your workbook.
Note the sheet references. Change as required.
Headers in Row1, Sheet3 have to be entered yet.



Sub Transfer_Into_Row()
Dim lr As Long, n As Long, a(), i As Long, j As Long, x As String, c As Range
Dim sh2 As Worksheet, sh3 As Worksheet
Set sh2 = Sheets("Sheet2")
Set sh3 = Sheets("Sheet3")
lr = sh2.Cells(Rows.Count, 1).End(xlUp).Row
n = 1
ReDim a(1 To n)
a(n) = sh2.Cells(2, 1).Value
i = 3
While Not IsEmpty(sh2.Cells(i, 1))
x = sh2.Cells(i, 1).Value
If IsError(Application.Match(x, a, 0)) Then
n = n + 1
ReDim Preserve a(1 To n)
a(n) = x
End If
i = i + 1
Wend


For j = 1 To UBound(a)
sh3.Cells(j + 1, 1).Value = a(j)
Next j


For Each c In sh2.Range("A2:A" & sh2.Cells(Rows.Count, 1).End(xlUp).Row)
c.Offset(, 1).Resize(, 3).Copy sh3.Cells(sh3.Columns(1).Find(c.Value, , , 1).Row, sh3.Columns.Count).End(xlToLeft).Offset(, 1)
Next c
End Sub

[jolivanes]

And I think that this should do everything you asked for.
The trying it on a copy of your workbook still stands as well as the sheet references.



Sub Transfer()
Dim lr As Long, n As Long, a(), i As Long, j As Long, k As Long, l As Long, m As Long
Dim x As String, c As Range
Dim sh2 As Worksheet, sh3 As Worksheet
Set sh2 = Sheets("Sheet2")
Set sh3 = Sheets("Sheet3")
lr = sh2.Cells(Rows.Count, 1).End(xlUp).Row


n = 1
ReDim a(1 To n)
a(n) = sh2.Cells(2, 1).Value
i = 3
While Not IsEmpty(sh2.Cells(i, 1))
x = sh2.Cells(i, 1).Value
If IsError(Application.Match(x, a, 0)) Then
n = n + 1
ReDim Preserve a(1 To n)
a(n) = x
End If
i = i + 1
Wend

For j = 1 To UBound(a)
sh3.Cells(j + 1, 1).Value = a(j)
Next j


For Each c In sh2.Range("A2:A" & sh2.Cells(Rows.Count, 1).End(xlUp).Row)
c.Offset(, 1).Resize(, 3).Copy sh3.Cells(sh3.Columns(1).Find(c.Value, , , 1).Row, sh3.Columns.Count).End(xlToLeft).Offset(, 1)
Next c


k = sh3.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column


sh3.Cells(1, 1).Value = "Reference Nr."
m = 1
For l = 2 To k Step 3
sh3.Cells(1, l).Value = "Item " & m
sh3.Cells(1, l + 1).Value = "Value " & m
sh3.Cells(1, l + 2).Value = "Purch Price " & m
m = m + 1
Next l


End Sub

[parag141]

Hi jolivanes

Thanks for your answer on this thread, I tried to copy this VBA code and changed the sheet reference but it gives stops at following code.



k = sh3.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column
[/CODE]

could you please check and let me know.

Many Thanks,

[jolivanes]

All that part does is find the last used cell to the right.
It should not give an error but it obviously does. Where did you change the sheet reference.
Show us the whole code so we can check it for you.


Try this. It is slightly different and does not use that line.
Let us know if this works.



Sub Transfer()
Dim lr As Long, n As Long, a(), i As Long, j As Long, k As Long, l As Long, m As Long, p As Long, iVal As Long
Dim x As String, c As Range
Dim sh2 As Worksheet, sh3 As Worksheet
Set sh2 = Sheets("Sheet2")
Set sh3 = Sheets("Sheet3")
lr = sh2.Cells(Rows.Count, 1).End(xlUp).Row
n = 1
ReDim a(1 To n)
a(n) = sh2.Cells(2, 1).Value
i = 3
While Not IsEmpty(sh2.Cells(i, 1))
x = sh2.Cells(i, 1).Value
If IsError(Application.Match(x, a, 0)) Then
n = n + 1
ReDim Preserve a(1 To n)
a(n) = x
End If
i = i + 1
Wend

iVal = 0
For p = LBound(a) To UBound(a)
If Application.WorksheetFunction.CountIf(sh2.Range("A2:A" & lr), a(p)) > iVal Then iVal = Application.WorksheetFunction.CountIf(sh2.Range("A2:A" & lr), a(p))
Next p


sh3.Cells(1, 1).Value = "Reference Nr."
m = 1
For l = 2 To iVal * 3 + 1 Step 3
sh3.Cells(1, l).Value = "Item " & m
sh3.Cells(1, l + 1).Value = "Value " & m
sh3.Cells(1, l + 2).Value = "Purch Price " & m
m = m + 1
Next l

For j = 1 To UBound(a)
sh3.Cells(j + 1, 1).Value = a(j)
Next j


For Each c In sh2.Range("A2:A" & sh2.Cells(Rows.Count, 1).End(xlUp).Row)
sh3.Cells(sh3.Columns(1).Find(c.Value, , , 1).Row, sh3.Columns.Count).End(xlToLeft).Offset(, 1).Resize(, 3).Value = c.Offset(, 1).Resize(, 3).Value
Next c


End Sub

[Paul_Hossler]

'nuther way

No fancy formatting on the generated worksheet




Option Explicit
Sub ReformatData()
Const colRef As Long = 1
Const colItem As Long = 2
Const colValue As Long = 3
Const colPur As Long = 4

Dim wsData As Worksheet, wsNew As Worksheet
Dim rData As Range, rDataNoHeader As Range, rNewRow As Range

Dim iRow As Long, iCount As Long, iCol As Long, iMax As Long

'init
Application.ScreenUpdating = False

Set wsData = Worksheets("Sheet1")
Set rData = wsData.Cells(1, 1).CurrentRegion
Set rDataNoHeader = rData.Cells(2, 1).Resize(rData.Rows.Count - 1, rData.Columns.Count)

'delete current and create new output sheet
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("New").Delete
Application.DisplayAlerts = True
On Error GoTo 0

Worksheets.Add.Name = "New"
Set wsNew = ActiveSheet


'sort in Ref and Item order
With wsData
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=rDataNoHeader.Columns(colRef), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=rDataNoHeader.Columns(colItem), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SetRange rData
.Sort.Header = xlYes
.Sort.MatchCase = False
.Sort.Orientation = xlTopToBottom
.Sort.SortMethod = xlPinYin
.Sort.Apply
End With

'brute force max number of items
With rData
iCount = 0
iMax = 0
For iRow = 2 To .Rows.Count
If .Cells(iRow, colRef).Value <> .Cells(iRow - 1, colRef).Value Then
iCount = Application.WorksheetFunction.CountIf(rData.Columns(colRef), .Cells(iRow, colRef).Value)
If iCount > iMax Then iMax = iCount
End If
Next iRow
End With

'add headers to output
With wsNew
iCol = 1
.Cells(1, iCol).Value = "Reference"
For iRow = 1 To iMax
iCol = iCol + 1
.Cells(1, iCol).Value = "Item" & iRow
iCol = iCol + 1
.Cells(1, iCol).Value = "Value" & iRow
iCol = iCol + 1
.Cells(1, iCol).Value = "Purchase" & iRow
Next iRow
End With
'move data from Data WS to New WS
With rData
For iRow = 2 To .Rows.Count

'start new ref num row
If .Cells(iRow, colRef).Value <> .Cells(iRow - 1, colRef).Value Then
Set rNewRow = wsNew.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow
iCol = 1
rNewRow.Cells(iCol).Value = .Cells(iRow, colRef).Value
End If

iCol = iCol + 1
rNewRow.Cells(iCol).Value = .Cells(iRow, colItem).Value
iCol = iCol + 1
rNewRow.Cells(iCol).Value = .Cells(iRow, colValue).Value
iCol = iCol + 1
rNewRow.Cells(iCol).Value = .Cells(iRow, colPur).Value

Next iRow
End With
Application.ScreenUpdating = True
End Sub