View Full Version : Rearranging data based on counter using VBA code
parag141
09-29-2015, 08:35 PM
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
09-30-2015, 11:52 PM
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
10-01-2015, 09:30 AM
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
10-01-2015, 02:19 PM
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
10-01-2015, 03:44 PM
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
10-03-2015, 03:09 PM
'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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.