32|EXCEL&VBA – Apple Sorting

[Mark]

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

We provide the solution to this challenge using:

• Excel
• VBA

Need a program? Click here.

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

• Challenge32_Apple_Sorting.xlsm

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

Challenge32_Solution.xlsm
Solution Video: Challenge 32|EXCEL&VBA – Apple Sorting

[Parker_Sherwood]

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 decade As Integer
    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:
        Set new_sheet = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
        new_sheet.Name = decade & "'s"
        CopyRangeByYear (decade)
        decade = decade + 10
    Next i
    
    

End Sub

Sub CopyRangeByYear(decade As Integer)
    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
    year_to_copy = Left(decade, 3)
    
    ' 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

[Sterling_Lane]

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

Sub decade_sheets()
'Dim variables
'Create_sheets loop variables
Dim first_year As Integer
Dim first_decade As Integer
Dim final_year As Integer
Dim final_decade As Integer
Dim total_sheets As Integer
Dim last_row As Long
' Assigning Rows to Decade Sheets Loop variables
Dim yr As String
Dim interim_decade As Integer
Dim decade As Integer
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)
first_decade = Left(CStr(first_year), 3)
last_row = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
final_year = year(ActiveSheet.Range("A" & last_row).Value)
final_decade = Left(CStr(final_year), 3)
total_sheets = (final_decade - first_decade) + 1
first_decade = first_decade & "0"
final_decade = final_decade & "0"
' Create sheets loop
interim_decade = first_decade
For index = 1 To total_sheets:
    ' Create new sheet
    Set new_Sheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    new_Sheet.Name = interim_decade & "'s"
    ' Add labels to the new sheet
    current_Sheet.Rows(1).Copy ThisWorkbook.Sheets(interim_decade & "'s").Rows(1)
    ' increment to next decade
    interim_decade = interim_decade + 10
Next index
'Reset index
current_Sheet.Activate
Set current_cell = ActiveSheet.Range("A2")
decade = first_decade
'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
    If interim_decade = decade Then
        ' 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
        ' Increment decade
        decade = decade + 10
        ' 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

[Christian]

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
            Sheets.Add(After:=Sheets("applerevenue")).Name = SheetName
            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

[Andrew]

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 @decade VARCHAR(4);

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
    PRINT 'Decade is: ' + @decade
    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;

[klayton]

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
        Set newWS = ThisWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
        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
        Set newWS = ThisWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
        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
        Set newWS = ThisWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
        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
        Set newWS = ThisWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
        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
        Set newWS = ThisWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
        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

[Justin_Rydalch]

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
    Sheets.Add(After:=Sheets("applerevenue")).Name = "1980s"
    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
    Sheets.Add(After:=Sheets("applerevenue")).Name = "1990s"
    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
    Sheets.Add(After:=Sheets("applerevenue")).Name = "2000s"
    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
    Sheets.Add(After:=Sheets("applerevenue")).Name = "2010s"
    Range("A1").PasteSpecial
    Worksheets("applerevenue").Activate
    '2020
    Range("A1").EntireColumn.AutoFilter Field:=Range("A1").Column, Criteria1:=">" & E10, Operator:=xlAnd, Criteria2:="<=" & E20
    
    Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
    Sheets.Add(After:=Sheets("applerevenue")).Name = "2020s"
    Range("A1").PasteSpecial
    Worksheets("applerevenue").Activate
End Sub