# 32|EXCEL&VBA – Apple Sorting

BYU Student Author: @Mark
Reviewers: @TylerBooth, @Erick_Sizilio
Estimated Time to Solve: 30 Minutes

We provide the solution to this challenge using:

• Excel
• VBA

Overview
As a teenager, you spent your summer vacations out in your parent’s apple orchard growing, picking, and sorting apples. Now, you are a financial analyst at an investment firm in charge of growing the firm’s excess cash by picking which stocks to invest in. Though not always a reliable indicator of future success, one characteristic that helps determine which stocks to pick is the stock price growth over time. You like to sort the prices by decade and compare them to general market trends. You have many stocks to choose from and want to be efficient with your time, so you resolve to dust off your rotting VBA skills and automate this sorting process…

Instructions
The reports you create are similar in formatting and structure, so you create a report from Apple’s stock data to create and test your VBA Macro. You want to create separate sheets displaying the stock prices by decade (ie, “1980s”, “1990s”, etc.) containing only the prices from the specific decade. The data contains dates through the current decade. Since you hate boring, repetitive tasks, you want to design the macro so that all you need to do is open the report, run the macro, and watch it sort for you.

Data Files

Suggestions and Hints

One method of solving this challenge is to filter the applerevenue data by the date column, copy the visible cells, paste the data into the new sheet, and repeat the code for each decade. Another (more difficult) method is to use a loop that uses the same filtering and copy/paste technique.

Solution

Except for that time I put myself in an endless loop (RIP me haha) this was a great challenge! It took me some time to do the challenge, but it did test my VBA skills. I didn’t take the approach in the suggestions, but that seems like a great way to approach the challenge! Here’s my solution code:

``````Sub Create_NewSheets()
Dim beg_year As Integer
Dim end_year As Integer
Dim LastRow As Long
Dim num_sheets As Byte
Dim i As Byte
Dim new_sheet As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook

LastRow = Range("A" & Rows.Count).End(xlUp).Row

beg_year = Right(Sheet1.Range("A2").Value, 4)
end_year = Right(Sheet1.Cells(LastRow, 1).Value, 4)
Debug.Print (beg_year & " " & end_year)

num_sheets = Left(end_year, 3) - Left(beg_year, 3) + 1
Debug.Print (num_sheets)

decade = Left(beg_year, 3) * 10

For i = 1 To num_sheets:
Next i

End Sub

Dim source_sheet As Worksheet
Dim dest_sheet As Worksheet
Dim source_last_row As Long
Dim start_row As Long
Dim last_row_with_year As Long
Dim source_range As Range
Dim year_to_copy As Integer

' Set the source sheet
Set source_sheet = ThisWorkbook.Sheets("applerevenue")

' Set the destination sheet
Set dest_sheet = ThisWorkbook.Sheets(decade & "'s")

' Set the year to copy

' Copy the first row of the source sheet to the destination sheet
source_sheet.Rows(1).Copy dest_sheet.Rows(1)

' Find the last row in column A of the source sheet
source_last_row = source_sheet.Cells(source_sheet.Rows.Count, "A").End(xlUp).Row

' Find the starting row based on your criteria
start_row = 2

' Loop through each row in column A of the source sheet from the bottom up
For i = source_last_row To start_row Step -1
' Check if the cell value is a valid date and if the year matches
If IsDate(source_sheet.Cells(i, "A").Value) And Left(Year(source_sheet.Cells(i, "A").Value), 3) = year_to_copy Then
' Set the last row with the year
last_row_with_year = i
' Exit the loop since we found the last instance of the year
Exit For
End If
Next i

' Set the source range to include all rows from the starting row to the last row with the year
Set source_range = source_sheet.Range("A" & start_row & ":G" & last_row_with_year)

' Copy and paste the range to the destination sheet
source_range.Copy dest_sheet.Cells(dest_sheet.Rows.Count, "A").End(xlUp).Offset(1)
End Sub
``````
2 Likes

This definitely did refresh my rotting VBA skills, that’s for sure! But I did learn quite a bit in the process so it was worth it! I decided to tackle the ‘harder’ version in the suggestions for this challenge with looping and keep everything to one sub. My code explanation is below.

I decided to create two separate for loops. The first loop analyzes the dataset to determine the first and final decades as well as how many decades are in between. It then loops through each decade, creating the sheet for said decade and populating the label row for each.

The second loop goes through each row of data, determines the decade of the data by extracting the year, and ensures it matches the current decade. If it matches, then it copies the row of data to the bottommost row of the relevant sheet and then the loop iterates. If the decade does not match, then that means that the first decade of data has been fully populated and this row of data begins the next decade. Thus, the decade variable is increased by 10 and the process repeats.

I’m sure my code could have been more efficient to accomplish this, but it gets the job done! I will say this took a while to run, but I suppose that’s to be expected due to the large volume of copying and pasting going on. Code is below.

``````Option Explicit

'Dim variables
'Create_sheets loop variables
Dim first_year As Integer
Dim final_year As Integer
Dim total_sheets As Integer
Dim last_row As Long
' Assigning Rows to Decade Sheets Loop variables
Dim yr As String
Dim last_row_dec As Long
'Both Loops variables
Dim index As Integer
Dim current_cell As Range
' Set worksheet and workbook variables
Dim new_Sheet As Worksheet
Dim current_Sheet As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set current_Sheet = ThisWorkbook.Sheets("applerevenue")

'Define range of Sheet Names
Set current_cell = ActiveSheet.Range("A2")
first_year = year(current_cell.Value)
last_row = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
final_year = year(ActiveSheet.Range("A" & last_row).Value)
' Create sheets loop
For index = 1 To total_sheets:
' Create new sheet
' Add labels to the new sheet
Next index
'Reset index
current_Sheet.Activate
Set current_cell = ActiveSheet.Range("A2")
'Loop through stock data and populate sheets based on the decade
For index = 2 To last_row
'Evaluate year to determine sheet the data belongs in
yr = Right(current_cell.Value, 4)
interim_decade = Left(yr, 3) & "0"
' Assign sheet name to relevant row value
' define last row of data from decade sheet
last_row_dec = Sheets(decade & "'s").Cells(Rows.Count, 1).End(xlUp).Row
' Copy row of data to the next row
current_Sheet.Rows(index).Copy ThisWorkbook.Sheets(decade & "'s").Rows(last_row_dec + 1)
' Increment loop
Set current_cell = current_cell.Offset(1, 0)
Else
' Define last row of data from decade sheet
last_row_dec = Sheets(decade & "'s").Cells(Rows.Count, 1).End(xlUp).Row
' Copy row of data to the next row
current_Sheet.Rows(index).Copy ThisWorkbook.Sheets(decade & "'s").Rows(last_row_dec + 1)
' Increment loop
Set current_cell = current_cell.Offset(1, 0)
End If
Next index

End Sub
``````

I love this challenge because it doesn’t seem to matter how much VBA coding you know. Anyone can do the challenge. I tried it with as simple of code as possible. It’s not the most efficient as it has to run through EVERY line of data and then compare it to however many pages have been made, but it is do-able with simple code as long as you work out the logic behind the process! Thanks for the challenge!!
Here’s my solution:

``````Sub extractData()
'Define key variables
Dim dateMain As Date
Dim rowIndex As Integer
Dim rowEnd As Long
Dim SheetName As String

'find start and end rows
rowIndex = 2
rowEnd = Cells(1, 1).End(xlDown).row
Do Until rowIndex = rowEnd
'set variable values
dateMain = Cells(rowIndex, 1).Value
Cells(rowIndex, 1).Activate
SheetName = Left(Year(dateMain), 3) & "0s"
i = 1
j = 0
'find the sheet by the year name
Do Until i = Sheets.Count + 1
If Sheets(i).Name = SheetName Then
Sheets("applerevenue").Activate
Range("A" & rowIndex, "G" & rowIndex).Copy Sheets(i).Cells(1, 1).End(xlDown).Offset(0, 1)
j = 1
End If
i = i + 1
Loop
If j = 0 Then
'if the sheet hasn't been found
Range("A1:G1").Copy Sheets(SheetName).Cells(1, 1)
Range("A" & rowIndex, "G" & rowIndex).Copy Sheets(SheetName).Cells(1, 1).Offset(1, 0)
Sheets("applerevenue").Activate
End If
'create loop
rowIndex = rowIndex + 1
Loop
End Sub
``````
1 Like

I uploaded this challenge into my local instance of SQL server.

Here is the T-SQL I wrote to complete the challenge:

``````IF OBJECT_ID('dbo.tempPrices') IS NOT NULL
DROP TABLE dbo.tempPrices;

CREATE TABLE dbo.tempPrices (
closeDate DATE
, stockOpen FLOAT
, stockHigh FLOAT
, stockLow FLOAT
, stockClose FLOAT
, volume INT
, increaseDecrease BIT
);

BULK INSERT dbo.tempPrices
FROM '<FILEPATH>'
WITH (
FIELDTERMINATOR = ','
, ROWTERMINATOR = '\n'
, FIRSTROW = 2
);

DECLARE myCursor CURSOR FOR
SELECT DISTINCT
CAST((YEAR(closeDate) / 10) AS VARCHAR(4)) + '0' AS decade
FROM dbo.tempPrices;

OPEN myCursor;
FETCH NEXT FROM myCursor INTO @decade;

WHILE @@FETCH_STATUS = 0
BEGIN
SELECT
*
FROM dbo.tempPrices
WHERE CAST((YEAR(closeDate) / 10) AS VARCHAR(4)) + '0' = @decade
FETCH NEXT FROM myCursor INTO @decade;
END

CLOSE myCursor;
DEALLOCATE myCursor;
``````

I had a great time with this challenge! I spent most of my time trying to find a way that wouldn’t take forever to go through the 10000-some lines of data. At first I was using copy and paste and that took forever, so instead I swapped to using varibles and it finishes in seconds now. I also created a separate function beneath the macro that checks whether or not the new sheet has already been created so the code doesn’t try and create a duplicate sheet. I had a lot of fun with it!

Also, for those without a lot of VBA experience, a pivot table could also prove a useful tool in this scenario!

``````Option Explicit

Sub sort_data()

Dim lrow As Long
Dim newlrow As Long
Dim yr As Integer
Dim dt As Date
Dim rev As Worksheet
Dim newWS As Worksheet
Dim x As Integer

Dim op As Double
Dim hi As Double
Dim low As Double
Dim cl As Double
Dim vol As Double
Dim inc As Integer

lrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

Set rev = ThisWorkbook.Sheets(1)

For x = 2 To lrow
dt = rev.Cells(x, 1).Value
yr = year(dt)

'''' 1980s
If yr >= 1980 And yr <= 1989 Then
If WorksheetExists("1980s") Then
Set newWS = Worksheets("1980s")
op = rev.Cells(x, 2).Value
hi = rev.Cells(x, 3).Value
low = rev.Cells(x, 4).Value
cl = rev.Cells(x, 5).Value
vol = rev.Cells(x, 6).Value
inc = rev.Cells(x, 7).Value

newlrow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
newWS.Cells(newlrow + 1, 1).Value = dt
newWS.Cells(newlrow + 1, 2).Value = op
newWS.Cells(newlrow + 1, 3).Value = hi
newWS.Cells(newlrow + 1, 4).Value = low
newWS.Cells(newlrow + 1, 5).Value = cl
newWS.Cells(newlrow + 1, 6).Value = vol
newWS.Cells(newlrow + 1, 7).Value = inc

Else
newWS.Name = "1980s"
rev.Select
Cells(x, 1).EntireRow.Copy
newlrow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
newWS.Cells(newlrow, 1).PasteSpecial

End If

End If

'''' 1990s
If yr >= 1990 And yr <= 1999 Then
If WorksheetExists("1990s") Then
Set newWS = Worksheets("1990s")
op = rev.Cells(x, 2).Value
hi = rev.Cells(x, 3).Value
low = rev.Cells(x, 4).Value
cl = rev.Cells(x, 5).Value
vol = rev.Cells(x, 6).Value
inc = rev.Cells(x, 7).Value

newlrow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
newWS.Cells(newlrow + 1, 1).Value = dt
newWS.Cells(newlrow + 1, 2).Value = op
newWS.Cells(newlrow + 1, 3).Value = hi
newWS.Cells(newlrow + 1, 4).Value = low
newWS.Cells(newlrow + 1, 5).Value = cl
newWS.Cells(newlrow + 1, 6).Value = vol
newWS.Cells(newlrow + 1, 7).Value = inc

Else
newWS.Name = "1990s"
rev.Select
Cells(x, 1).EntireRow.Copy
newlrow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
newWS.Cells(newlrow, 1).PasteSpecial

End If

End If

'''' 2000s
If yr >= 2000 And yr <= 2009 Then
If WorksheetExists("2000s") Then
Set newWS = Worksheets("2000s")
op = rev.Cells(x, 2).Value
hi = rev.Cells(x, 3).Value
low = rev.Cells(x, 4).Value
cl = rev.Cells(x, 5).Value
vol = rev.Cells(x, 6).Value
inc = rev.Cells(x, 7).Value

newlrow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
newWS.Cells(newlrow + 1, 1).Value = dt
newWS.Cells(newlrow + 1, 2).Value = op
newWS.Cells(newlrow + 1, 3).Value = hi
newWS.Cells(newlrow + 1, 4).Value = low
newWS.Cells(newlrow + 1, 5).Value = cl
newWS.Cells(newlrow + 1, 6).Value = vol
newWS.Cells(newlrow + 1, 7).Value = inc

Else
newWS.Name = "2000s"
rev.Select
Cells(x, 1).EntireRow.Copy
newlrow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
newWS.Cells(newlrow, 1).PasteSpecial

End If

End If

'''' 2010s
If yr >= 2010 And yr <= 2019 Then
If WorksheetExists("2010s") Then
Set newWS = Worksheets("2010s")
op = rev.Cells(x, 2).Value
hi = rev.Cells(x, 3).Value
low = rev.Cells(x, 4).Value
cl = rev.Cells(x, 5).Value
vol = rev.Cells(x, 6).Value
inc = rev.Cells(x, 7).Value

newlrow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
newWS.Cells(newlrow + 1, 1).Value = dt
newWS.Cells(newlrow + 1, 2).Value = op
newWS.Cells(newlrow + 1, 3).Value = hi
newWS.Cells(newlrow + 1, 4).Value = low
newWS.Cells(newlrow + 1, 5).Value = cl
newWS.Cells(newlrow + 1, 6).Value = vol
newWS.Cells(newlrow + 1, 7).Value = inc

Else
newWS.Name = "2010s"
rev.Select
Cells(x, 1).EntireRow.Copy
newlrow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
newWS.Cells(newlrow, 1).PasteSpecial

End If

End If

'''' 2020s
If yr >= 2020 And yr <= 2029 Then
If WorksheetExists("2020s") Then
Set newWS = Worksheets("2020s")
op = rev.Cells(x, 2).Value
hi = rev.Cells(x, 3).Value
low = rev.Cells(x, 4).Value
cl = rev.Cells(x, 5).Value
vol = rev.Cells(x, 6).Value
inc = rev.Cells(x, 7).Value

newlrow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
newWS.Cells(newlrow + 1, 1).Value = dt
newWS.Cells(newlrow + 1, 2).Value = op
newWS.Cells(newlrow + 1, 3).Value = hi
newWS.Cells(newlrow + 1, 4).Value = low
newWS.Cells(newlrow + 1, 5).Value = cl
newWS.Cells(newlrow + 1, 6).Value = vol
newWS.Cells(newlrow + 1, 7).Value = inc

Else
newWS.Name = "2020s"
rev.Select
Cells(x, 1).EntireRow.Copy
newlrow = newWS.Cells(Rows.Count, 1).End(xlUp).Row
newWS.Cells(newlrow, 1).PasteSpecial

End If

End If

Application.CutCopyMode = False
DoEvents
Next x
Beep
End Sub

Function WorksheetExists(sheetName As String) As Boolean
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name = sheetName Then
WorksheetExists = True
Exit Function
End If
Next ws
WorksheetExists = False
End Function

``````

I enjoy looking for different ways to solve the same problem and really needed this refresher for VBA, thank you for the problem!

Here is my solution:

``````Sub Apple_Sort()
Dim Beg, E80, E90, E00, E10, E20

'Define variables

Beg = "01/01/1980"
E80 = "12/31/1989"
E90 = "12/31/1999"
E00 = "12/31/2009"
E10 = "12/31/2019"
E20 = "12/31/2029"

'1980
Range("A1").EntireColumn.AutoFilter Field:=Range("A1").Column, Criteria1:=">=" & Beg, Operator:=xlAnd, Criteria2:="<=" & E80

Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Range("A1").PasteSpecial
Worksheets("applerevenue").Activate

'1990
Range("A1").EntireColumn.AutoFilter Field:=Range("A1").Column, Criteria1:=">" & E80, Operator:=xlAnd, Criteria2:="<=" & E90

Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Range("A1").PasteSpecial
Worksheets("applerevenue").Activate
'2000
Range("A1").EntireColumn.AutoFilter Field:=Range("A1").Column, Criteria1:=">" & E90, Operator:=xlAnd, Criteria2:="<=" & E00

Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Range("A1").PasteSpecial
Worksheets("applerevenue").Activate
'2010
Range("A1").EntireColumn.AutoFilter Field:=Range("A1").Column, Criteria1:=">" & E00, Operator:=xlAnd, Criteria2:="<=" & E10

Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy