Data crunching according to criteria

[gojakie]

Hello everyone,

I am trying to crunch stock market data and need help.

Following is my sample data in the range A111

Time Scrip Quote Volume
10:00 A 10 1000
10:00 B 9 1
10:00 C 20 9876
10:00 D 15 2
10:00 E 8 6543
11:00 A 11 2500
11:00 B 9 1
11:00 C 30 22222
11:00 D 12 3
11:00 E 9 15000

I need an output in sheet2 which is as follows:

Scrip High Low Swing
C 30 20 50.00
E 9 8 12.50
A 11 10 10.00

Here is how I calculate Swing:
Swing = ((Max-Min)/Min)*100

Criteria:
1. Find Swing using the above formula
2. Sort the output on Swing (Descending)
3. Do not show scrips in the output if the volume is less than 0.02%
of the MAX volume.

Can somebody help me with a macro which gives me the above output
based on the three conditions?

Thank you

 

[Barb Reinhardt]

You can get much of this with a Pivot Table. Have you considered that or do
you want something programmatically?

Barb Reinhardt

 

[Mike]

This might work
Sub Macro1()
Const sh1 As String = "Sheet1"
Const sh2 As String = "Sheet2"
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim r As Long
Dim lastrow As Long

Set ws1 = Worksheets(sh1)
Set ws2 = Worksheets(sh2)

lastrow = ws1.Cells(Rows.Count, 1).End(xlUp).Row

ws1.Range("B1:B" & lastrow).AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=ws2.Range("A1"), Unique:=True
Application.ScreenUpdating = False
r = 2
With ws1
.Range("D" & lastrow).Offset(1, 0).Value = "=SUM(D2" & lastrow & ")"
Do While Len(.Range("A" & r).Formula) > 0
.Range("E" & r).Value = "=D" & r & "/$D$12"
r = r + 1
Loop
End With

r = 2
With ws2
Do While Len(.Range("A" & r).Formula) > 0
.Range("F" & r).Value = "=SUMPRODUCT(--(Sheet1!$B$2:$B$11=Sheet2!A" & r
& ")*Sheet1!$D$2:$D$11)"
.Range("G" & r).Value = "=SUMPRODUCT(--(Sheet1!B2:B11=A" & r &
")*Sheet1!E2:E11)"
.Range("G" & r).NumberFormat = "0.00%"
r = r + 1
Loop
r = 2
Do While Len(.Range("A" & r).Formula) > 0
.Range("B" & r).FormulaArray = "=MAX((Sheet1!$B$2:$B$11=A" & r &
")*(Sheet1!$C$2:$C$11))"
.Range("C" & r).FormulaArray = "=MIN(IF(--(Sheet1!$B$2:$B$11=A" & r
& "),(Sheet1!$C$2:$C$11)))"
.Range("D" & r).Value = Evaluate("=((Sheet2!B" & r & " - Sheet2!C" &
r & ") / Sheet2!C" & r & ") * 100")
.Range("D" & r).NumberFormat = "0.00"
r = r + 1
Loop
End With
ws2.Activate
Set Rng = ws2.Range(Cells(2, "G"), Cells(Rows.Count, "G").End(xlUp))
With Rng
For i = .Rows.Count To 1 Step -1
If .Cells(i) < 0.002 Then
.Cells(i).EntireRow.delete
End If
Next i
End With

ws1.Activate
ws1.Columns("E:E").ClearContents
ws1.Range("D" & lastrow + 1).ClearContents
ws2.Columns("F:G").ClearContents

ActiveWorkbook.Worksheets(sh2).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(sh2).Sort.SortFields.Add Key:=Range("D1"),
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
lastrow = ws2.Cells(Rows.Count, 1).End(xlUp).Row

With ActiveWorkbook.Worksheets(sh2).Sort
.SetRange Range("A1" & lastrow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Application.ScreenUpdating = True
End Sub

 

[Mike]

Try this.
Sub crunchStockMarketData()
Const scripColumnSheet2 As String = "A"
Const scripColumnSheet1 As String = "B"
Const maxColumn As String = "B"
Const minColumn As String = "C"
Const quoteColumn As String = "C"
Const swingColumn As String = "D"
Const volumeColumn As String = "D"
Const tempColumn As String = "E"
Const sh1 As String = "Sheet1"
Const sh2 As String = "Sheet2"
Const SOD As String = 2
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim r As Long
Dim lastrow As Long

Set ws1 = Worksheets(sh1)
Set ws2 = Worksheets(sh2)

lastrow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
ws2.Cells.delete

ws1.Range(scripColumnSheet1 & 1 & ":" & scripColumnSheet1 &
lastrow).AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=ws2.Range(scripColumnSheet2 & 1), Unique:=True
Application.ScreenUpdating = False

r = 2
With ws1
.Range(volumeColumn & lastrow).Offset(1, 0).Value = "=SUM(" &
volumeColumn & SOD & ":" & volumeColumn & lastrow & ")"
Do While Len(.Range(scripColumnSheet1 & r).Formula) > 0
.Range(tempColumn & r).Value = "=" & volumeColumn & r & "/" &
volumeColumn & lastrow + 1 & ""
r = r + 1
Loop
End With

r = 2
With ws2
Do While Len(.Range(scripColumnSheet2 & r).Formula) > 0
'.Range(maxColumn & r).Value = "=SUMPRODUCT(--(" & sh1 & "!" &
scripColumnSheet1 & SOD & ":" & scripColumnSheet1 & lastrow & "=" &
scripColumnSheet2 & r & ")*" & sh1 & "!" & volumeColumn & SOD & ":" &
volumeColumn & lastrow & ")"
.Range(maxColumn & r).Value = "=SUMPRODUCT(--(" & sh1 & "!" &
scripColumnSheet1 & SOD & ":" & scripColumnSheet1 & lastrow & "=" &
scripColumnSheet2 & r & ")*" & sh1 & "!" & tempColumn & SOD & ":" &
tempColumn & lastrow & ")"
r = r + 1
Loop
.Activate
Set rng = .Range(Cells(SOD, maxColumn), Cells(Rows.Count,
maxColumn).End(xlUp))
With rng
For i = .Rows.Count To 1 Step -1
If .Cells(i) < 0.002 Then
.Cells(i).EntireRow.delete
End If
Next i
End With

r = 2
Do While Len(.Range(scripColumnSheet2 & r).Formula) > 0
.Range(maxColumn & r).FormulaArray = "=MAX((" & sh1 & "!" &
scripColumnSheet1 & SOD & ":" & scripColumnSheet1 & lastrow & "=" &
scripColumnSheet2 & r & ")*(" & sh1 & "!" & quoteColumn & SOD & ":" &
quoteColumn & lastrow & "))"
.Range(maxColumn & r).Value = .Range(maxColumn & r).Value
.Range(maxColumn & r).NumberFormat = "0"
.Range(minColumn & r).FormulaArray = "=MIN(IF(--(" & sh1 & "!" &
scripColumnSheet1 & SOD & ":" & scripColumnSheet1 & lastrow & "=" &
scripColumnSheet2 & r & "),(" & sh1 & "!" & quoteColumn & SOD & ":" &
quoteColumn & lastrow & ")))"
.Range(minColumn & r).Value = .Range(minColumn & r).Value
.Range(minColumn & r).NumberFormat = "0"
.Range(swingColumn & r).Value = Evaluate("=((" & maxColumn & r & " -
" & minColumn & r & ") / " & minColumn & r & ") * 100")
.Range(swingColumn & r).Value = .Range(swingColumn & r).Value
.Range(swingColumn & r).NumberFormat = "0.00"
r = r + 1
Loop
.Range(scripColumnSheet2 & 1).Activate
.Range(maxColumn & 1).Value = "High"
.Range(minColumn & 1).Value = "Low"
.Range(swingColumn & 1).Value = "Swing"
End With

ActiveWorkbook.Worksheets(sh2).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(sh2).Sort.SortFields.Add
Key:=Range(swingColumn & 1), SortOn:=xlSortOnValues, Order:=xlDescending,
DataOption:=xlSortNormal

lastrow = ws2.Cells(Rows.Count, 1).End(xlUp).Row
With ActiveWorkbook.Worksheets(sh2).Sort
.SetRange Range(scripColumnSheet2 & 1 & ":" & swingColumn & lastrow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

lastrow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
With ws1
.Activate
.Columns(tempColumn & ":" & tempColumn).ClearContents
.Range(volumeColumn & lastrow + 1).ClearContents
End With
Application.ScreenUpdating = True

End Sub