sorting and tranposing of data

**bgunawan** · 06-26-2009, 09:20 AM

Hi gurus, I have a spreadsheet which the data looks like the below. The below example has been filtered using subtotal function.

a/c code qty identifier
MLI08 AAC 4972 16158174
MLI08 AAC -4972 16158253
AAC Total 0
MLI08 AAX 25502 16157031
MLI08 AAX -11817 16157317
MLI08 AAX -13685 16158058
AAX Total 0
MLI08 ABB -3439 16157779
MLI08 ABB -404 16157794
MLI08 ABB 3843 16157933
ABB Total 0
MLI08 ABC 32738 16157973
MLI08 ABC -4963 16158035
MLI08 ABC -27775 16158169
ABC Total 0
MLI08 AGK -1006 16157446
MLI08 AGK 1006 16157969
AGK Total 0
MLI08 AGO -30801 16157719
MLI08 AGO 30801 16158072
AGO Total 0
MLI08 AIO -58530 16157178
MLI08 AIO 85389 16157967
MLI08 AIO -26859 16158235
AIO Total 0

MLI08 GCL 86 16146585
MLI08 GCL -455 16157064
MLI08 GCL 455 16157257
GCL Total 86
MLI08 MGR 104051 16157552
MLI08 MGR -117441 16158196
MLI08 MGR -31573 16158209
MLI08 MGR -39320 16167570
MGR Total -84283
MLI08 MMG 52969 16157409
MLI08 MMG -31713 16157514

I would say the above grouping should be on the way to how i need the data to be presented. I need help from the excel gurus in this form to essentially transform the above data into the following format.

For the first data as an example, AAC info should be transformed into
16158174 16158253 4972
identifier of postive qty identifier of negative qty qty

The above example shows identifier where it can be linked as both qty is the same and it's just the sign that's different.

It becomes trickier when there are multiple lines for that stock code but when you total the qty, it adds up to zero due to positive and negative cancelling each other. One of the example above which illustrates this is:

MLI08 AIO -58530 16157178
MLI08 AIO 85389 16157967
MLI08 AIO -26859 16158235
AIO Total 0

In this instance, i need first of all, to find which qty is the maximum. The sign in front of the number does not make a difference. That is -85,389 and 85,389 are treated to be the same. And the above should be transformed into:

16157967 16157178 58530
16157967 16158235 26859

16157967 is the identifier of 85,389 and in this scenario is the maximum value relative to the other 2 quantity and hence that identifier has to be put in the left hand side column whilst the remaining identifier has to be put on the right hand column.

There are instances also where the subtotal does not equal to zero, just like the example below:

MLI08 GCL 86 16146585
MLI08 GCL -455 16157064
MLI08 GCL 455 16157257
GCL Total 86

in this instance, i need the data to be transformed into:

16157064 16157257 455

we will ignore the identifier for 86.

not sure if this is possible. Not 100% sure on how to write the code as firstly, I'm not very good with vba and secondly i couldn't find any info on the net which show how to do this sort of sorting using vba. I have also attached a copy of the data on a spreadsheet.

I have no problems writing simple vba to do simple stuff but clearly the above exercise is way out of my league. What troubles me the most is that you have to write a code which will first check to see if how many rows are there for each stock code, then another code which essentially find the max qty for each stock code and finally rearrange the data into the way it needs to be presented for my purpose.

so any help would be deeply appreciated. thanks beforehand.

**StephenR** · 06-26-2009, 10:04 AM

So the identifier is in column B. Cases where two values sum to zero are to be treated differently to cases where more than two values sum to zero.

Where two or more values do not sum to zero, find the subset of values which sum to zero and then treat as above.

Is it possible for no subset of values to equal zero, and if so are they ignored?

Have I understood correctly?

**bgunawan** · 06-26-2009, 06:12 PM

in the spreadsheet attached, the identifier is in column D. Column B is a stock code. Apology for not putting in the header. However, in the spreadsheet, Column A is A/C, Column B is Stock Code, Column C is the qty where positive is a buy and negative is a sell and lastly, Column D is the unique identifier for that particular buy or sell trade and will never be repeated.

I need the code to first of all recognise that in the data, they will be multiple groups. That is, in my example, AAC should be classified as 1 group, AAX should be another, so on and so forth.

Once it has done that, the code should then do a MAX() to find which qty is the greatest, ignoring the sign at the front.

Finally, re-arrange the data so that, e.g.

1st identifier, say paste in Column A, would be the identifier which relates to that stock code which has the maximum qty. 2nd identifier, say in Column D, should relate to the opposite quantity of 1st identifier. and Finally, say Column F, would be the qty in absolute value.

In its simplest form,

Identifier 1 Identifier 2 Qty
this could relate to this could relate to absolute value of the qty identified
positive or negative qty positive or negative qty

There is definitely a posibility whereby a subset of values does not equal to zero. In that instance, if there's a positive and quantitive qty for that code, the minimum of the two qty in absolute terms.

e.g. in the attachment, if you scroll down to code MGR (Column B), you would find the below data:

A/C Code Qty Identifier
MLI08 MGR 104051 16157552
MLI08 MGR -117441 16158196
MLI08 MGR -31573 16158209
MLI08 MGR -39320 16167570

There is no way where you can find a subset which would equal to zero. However, i need to code to sort to become the following as there is a certain qty which can be contra off each other:

16158196 16157552 104051

It's important that one identifer relate to a positive qty and the other negtive qty. if a subset only has positive qty, then ignore. Likewise, if there's only negative qty, then ignore too. Only when there is a positive qty and negative qty for that stock code should the sorting then apply.

But StephenR, you have definitely got the drift. Hopefully, the above explanation should make it clearer rather than confuse you. Also, this report is generated on a daily basis and hence the list is dynamic. It maybe long 1 day and quite short on another.

thanks.

**bgunawan** · 07-01-2009, 09:49 AM

Hi StephenR,

I've found a solution to my problem and it's running well now. It may not be the most efficient code but it does the work.

Thanks for your help anyway.

**StephenR** · 07-01-2009, 11:00 AM

OK, afraid this slipped my mind in the absence of any jogging!

Perhaps you'd care to post your code for anyone else searching the forums.

**bgunawan** · 07-08-2009, 01:03 AM

Sorry StephenR, Haven't been checking my e-mail.

But the below is what I have compiled. Of course, these are codes which I have searched through google and improvise on to suit my need.

PHP Code:


Sub Contra()



Dim LRow As Integer

Dim LColARange As String

Dim LContinue As Boolean

Dim rng As Range

Dim rng1 As Range

Dim last As Long

Dim last1 As Long

Dim WSD As Worksheet

Set WSD = ActiveSheet

Dim PRange As Range

Dim finalRow As Long

Dim finalCol As Long

Dim lngRows As Long

Dim lngRows1 As Long



'check sheet1's name

If ActiveSheet.name <> "Sheet1" Then ActiveSheet.name = "Sheet1"





'check if Sheet2 exist

Set sht = Worksheets("Sheet2")

If sht Is Nothing Then Worksheets.Add: ActiveSheet.name = "Sheet2"



 

'absolute value negative qty



Sheets("Sheet1").Range("D1").Select

Selection.EntireColumn.Select

Selection.Insert Shift:=xlToRight

Range("D1").Select

Selection.Formula = "=abs(rc[-1])"

last = Range("C65536").End(xlUp).Row

Selection.AutoFill Destination:=Range("D1:D" & last)



Range("F1").Select

Selection.Formula = "=CONCATENATE(RC[-4],RC[-2])"

last1 = Range("E65536").End(xlUp).Row

Selection.AutoFill Destination:=Range("F1:F" & last1)





Range("G1").Select

Selection.Formula = "=COUNTIF(C[-1],RC[-1])"

Selection.AutoFill Destination:=Range("G1:G" & last1)

 

 

' Find the last row with data

finalRow = WSD.Cells(Application.Rows.Count, 1).End(xlUp).Row





' Find the last column with data

finalCol = WSD.Cells(1, Application.Columns.Count).End(xlToLeft).Column



 

' Find the range of the data

Set PRange = WSD.Cells(1, 1).Resize(finalRow, finalCol)

 



'sort by perfect match



PRange.sort Key1:=Range("G1"), Order1:=xlDescending, Header:= _

        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

        DataOption1:=xlSortNormal



Columns("G:G").Select

    Selection.Find(What:="1", After:=ActiveCell, LookIn:=xlValues, LookAt:= _

        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _

        SearchFormat:=False).Activate



ActiveCell.End(xlToLeft).Select

Selection.EntireRow.Select

Selection.Insert Shift:=xlDown

ActiveCell.Select

Selection.Value = "MLI08"

ActiveCell.Offset(0, 1).Select

Selection.Value = "XXX"

ActiveCell.Offset(1, 5).Select



'sort the remaining

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlToLeft)).Select

Selection.sort Key1:=Range("B152"), Order1:=xlAscending, Key2:=Range( _

        "D152"), Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, _

        MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _

        DataOption2:=xlSortNormal



Startpoint:



'Select ActiveSheet

Sheets("Sheet1").Range("B1").Select

 

'Initialize variables

LContinue = True

LRow = 1



'Loop through all column B values until a blank cell is found or value does not

' match cell B1's value

While LContinue = True

LRow = LRow + 1

LColARange = "B" & CStr(LRow)



'Found a blank cell, do not continue

If Len(Range(LColARange).Value) = 0 Then

LContinue = False

End If



'Found first occurrence that did not match cell B1's value, do not continue

If Range("B1").Value <> Range(LColARange).Value Then

LContinue = False

End If



Wend





'Copy data from columns A - G

Range("A1:G" & CStr(LRow - 1)).Select

Selection.Cut



'Paste results to cell A1 in Sheet2

Sheets("Sheet2").Select

Range("A1").Select

ActiveSheet.Paste



 

'Processing Tranposing

If Range("A1").Value = "" Then



Range("H1").Select

 

    Do

    

    If IsEmpty(ActiveCell) Then

    ActiveCell.FormulaR1C1 = "=R[-1]C"

    End If

    

    ActiveCell.Offset(1, 0).Select

    

    Loop Until IsEmpty(ActiveCell.Offset(0, 1))

    

    MsgBox "Tranposing is now complete!"

    

    Exit Sub



Else



If Range("G1").Value = 2 Then

ActiveSheet.Range("E1:E2").Select

Selection.Copy



    If Range("H1").Value = "" Then

        Range("H1").Select

        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _

            False, Transpose:=True

        Application.CutCopyMode = False



        



        Range("D2").Select

        Selection.Copy

        Range("H1").Offset(0, 3).Select

        Selection.PasteSpecial Paste:=xlValues

        Application.CutCopyMode = False

        Range("A1:G65536").Select

        Selection.ClearContents



    Else



        Range("I65536").Select

        Selection.End(xlUp).Select

        Selection.Offset(1, -1).Select

        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _

            False, Transpose:=True

        Application.CutCopyMode = False



        

        Range("D2").Select

        Selection.Copy

        Range("K65536").Select

        Selection.End(xlUp).Select

        Selection.Offset(1, 0).Select

        Selection.PasteSpecial Paste:=xlValues

        Application.CutCopyMode = False

        Range("A1:G65536").Select

        Selection.ClearContents



   End If



Else



'count the number of rows

lngRows = Range("A1").CurrentRegion.Rows.Count



End If



End If





'Sort and Tranpose

Select Case lngRows



 

Case 1



Range("A1:G65536").Select

Selection.ClearContents



 

Case 2



ActiveSheet.Range("E1:E2").Select

Selection.Copy



    If Range("H1").Value = "" Then

        Range("H1").Select

        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _

            False, Transpose:=True

        Application.CutCopyMode = False



        



        Range("D2").Select

        Selection.Copy

        Range("H1").Offset(0, 3).Select

        Selection.PasteSpecial Paste:=xlValues

        Application.CutCopyMode = False

        Range("A1:G65536").Select

        Selection.ClearContents



    Else



        Range("I65536").Select

        Selection.End(xlUp).Select

        Selection.Offset(1, -1).Select

        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _

            False, Transpose:=True

        Application.CutCopyMode = False



        

        Range("D2").Select

        Selection.Copy

        Range("K65536").Select

        Selection.End(xlUp).Select

        Selection.Offset(1, 0).Select

        Selection.PasteSpecial Paste:=xlValues

        Application.CutCopyMode = False

        Range("A1:G65536").Select

        Selection.ClearContents



   End If



    

Case Is > 2



ActiveSheet.Range("E1:E2").Select

Selection.Copy



 

    If Range("H1").Value = "" Then

        Range("H1").Select

        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _

            False, Transpose:=True

        Application.CutCopyMode = False



        Range("D2").Select

        Selection.Copy

        Range("H1").Offset(0, 3).Select

        Selection.PasteSpecial Paste:=xlValues

        Application.CutCopyMode = False



        

        Range("E3:E100").Select

        Selection.Copy

        Range("I65536").Select

        Selection.End(xlUp).Select

        Selection.Offset(1, 0).Select

        Selection.PasteSpecial Paste:=xlValues

        Application.CutCopyMode = False



        

        Range("D3:D100").Select

        Selection.Copy

        Range("K65536").Select

        Selection.End(xlUp).Select

        Selection.Offset(1, 0).Select

        Selection.PasteSpecial Paste:=xlValues

        Application.CutCopyMode = False



        Range("A1:G65536").Select

        Selection.ClearContents



    Else



        Range("I65536").Select

        Selection.End(xlUp).Select

        Selection.Offset(1, -1).Select

        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _

            False, Transpose:=True

        Application.CutCopyMode = False



        

        Range("D2").Select

        Selection.Copy

        Range("K65536").Select

        Selection.End(xlUp).Select

        Selection.Offset(1, 0).Select

        Selection.PasteSpecial Paste:=xlValues

        Application.CutCopyMode = False



    

        Range("E3:E100").Select

        Selection.Copy

        Range("I65536").Select

        Selection.End(xlUp).Select

        Selection.Offset(1, 0).Select

        Selection.PasteSpecial Paste:=xlValues

        Application.CutCopyMode = False

        Range("D3:D100").Select

        Selection.Copy

        Range("K65536").Select

        Selection.End(xlUp).Select

        Selection.Offset(1, 0).Select

        Selection.PasteSpecial Paste:=xlValues

        Application.CutCopyMode = False

        Range("A1:G65536").Select

        Selection.ClearContents



    End If



End Select



Sheets("Sheet1").Select

Selection.Delete Shift:=xlUp





GoTo Startpoint





End Sub

**StephenR** · 07-08-2009, 09:02 AM

Thanks for posting that. To make code quicker as well as more elegant you can generally remove a lot of the Select statements thrown up my the macro recorder. For example, this

Sheets("Sheet1").Range("D1").Select 
Selection.EntireColumn.Select 
Selection.Insert Shift:=xlToRight 
Range("D1").Select 
Selection.Formula = "=abs(rc[-1])" 
last = Range("C65536").End(xlUp).Row 
Selection.AutoFill Destination:=Range("D1:D" & last) 

Range("F1").Select 
Selection.Formula = "=CONCATENATE(RC[-4],RC[-2])" 
last1 = Range("E65536").End(xlUp).Row 
Selection.AutoFill Destination:=Range("F1:F" & last1) 


Range("G1").Select 
Selection.Formula = "=COUNTIF(C[-1],RC[-1])" 
Selection.AutoFill Destination:=Range("G1:G" & last1)

could be replaced with this (though untested):

Sheets("Sheet1").Range("D1").EntireColumn.Insert Shift:=xlToRight
With Range("D1")
    .Formula = "=abs(rc[-1])"
    last = Range("C65536").End(xlUp).Row
    .AutoFill Destination:=Range("D1:D" & last)
End With
With Range("F1")
    .Formula = "=CONCATENATE(RC[-4],RC[-2])"
    last1 = Range("E65536").End(xlUp).Row
    .AutoFill Destination:=Range("F1:F" & last1)
End With
With Range("G1")
    .Formula = "=COUNTIF(C[-1],RC[-1])"
    .AutoFill Destination:=Range("G1:G" & last1)
End With

**bgunawan** · 07-08-2009, 08:37 PM

Good thinking. I'll remember next time. I didn't really use much macro recorder for the code. I wrote as I think how it will happen hence the similarity with the macro recorder. I'll give your suggestion a try.

Thanks once again.

Just a quick question, do you know if there's any VBA code that will allow me to limit the time on code execution. That is, i want the macro to use only e.g. 5 minutes to run, any longer than that, it will abort and resume next.

**broro183** · 07-08-2009, 09:24 PM

Giday,

Just a quick question, do you know if there's any VBA code that will allow me to limit the time on code execution. That is, i want the macro to use only e.g. 5 minutes to run, any longer than that, it will abort and resume next.

As Stephen mentioned, your code can be optimised a lot by removing the ".select" and various other approaches. I think that someone will probably be able to get optimise your code & get the run time down to no more than a minute or two for everything to be done therefore removing the need for time limitations...

Can you please post the latest sample file with your code?
(If you are interested in more help, it may be best to remove the "solved" prefix from your post.)

Rob

**bgunawan** · 07-08-2009, 11:45 PM

Hi broro183,

The problem related to this post is resolved. The question that I posted to StepenR is related to another new post which I have just started.

http://www.excelforum.com/excel-prog...execution.html

Perhaps I shouldn't asked that question in this post given the fact that I've started a new post for that question. My apology. I have updated all the relevant info in the new post. It'd be much appreciated if you could shed some light.

Thanks.