Loop with "Select Cases" combined - vba

Question

I have attempted to combine a simple loop code and select cases to return a desired user result (I am aware the code is incorrect). Within column J I have a series of years ranging from 2012 to 2017 dependant on the year in column J I wish to cut the data from column U to AG and paste it, in its correct place.
The code I have come up with is below;
Sub Move_data()
Dim rng As Range
Dim LR As Long
LR = Range("J1048576").End(xlUp).Row
Set rng = Range(Cells(2, 10), Cells((LR), 10))
For x = 2 To LR Step 1
Select Case Range("J" & x).Value2
Case 2012
Range("BU" & x).Cut
Range("IH" & x).Paste
Range("U" & x, ":CG" & x).Cut
Range("AH" & x).PasteSpecial
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
Case 2013
Range("BU" & x).Cut
Range("IH" & x).Paste
Range("U" & x, ":CG" & x).Cut
Range("AU" & x).PasteSpecial
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
Case 2014
Range("BU" & x).Cut
Range("IH" & x).Paste
Range("U" & x, ":CG" & x).Cut
Range("BH" & x).PasteSpecial
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
Case 2015
Range("BU" & x).Cut
Range("IH" & x).Paste
Range("U" & x, ":CG" & x).Cut
Range("BU" & x).PasteSpecial
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
Case 2016
Range("BU" & x).Cut
Range("IH" & x).Paste
Range("U" & x, ":CG" & x).Cut
Range("CH" & x).PasteSpecial
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
Case 2017
Range("BU" & x).Cut
Range("IH" & x).Paste
Range("U" & x, ":CG" & x).Cut
Range("CU" & x).PasteSpecial
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
End Select
x = x + 1
Else
End If
Next x
End Sub
Also I have a feeling it may not be time efficient to loop through each line as there is over 1000 lines within the file, It may be quicker to sort and select all the same years and move the data all at once. (However I am unsure of how to do this)
Any help in code adaptation or guidance of the best way to achieve this would be much appreciated! I have attached a picture for guidance of what I am trying to achieve.

Answer 1

While this won't do exactly what you're looking for, it will give you an idea on how to get started using tables. This will detect unique values in your table (instead of setting your case examples) and then try to track it through. You'll have to convert your data source to a table (listobject) and there are a few other things which you will need to modify (have tried to highlight them with comments. Have a look through the code and feel free to ask any questions if it's of use.
Data source (table)
Code
Option Explicit
Sub tableLoop()
Dim ws As Worksheet
Dim tbl As ListObject
Dim i As Integer: Dim NoRow As Integer
Dim arr() As Variant
Dim c
With Application
.ScreenUpdating = False
End With
Set ws = ActiveSheet
Set tbl = ws.ListObjects(1)
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
' first we will sort the table into order on year
With tbl.Sort
.SortFields.Clear
' Change the Range to match your table and year column)
.SortFields.Add Key:=Range("Table1[[#All],[Project Year]]"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Get unique values in project year and put into array
With tbl.ListColumns(1).DataBodyRange
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
End With
i = 0
For Each c In tbl.ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible)
ReDim Preserve arr(0 To i)
arr(i) = c.Value
i = i + 1
Next c
' Change this loop for however you want the output to be
For i = 1 To UBound(arr)
Debug.Print arr(i)
With tbl
.Range.AutoFilter Field:=1, Criteria1:=arr(i)
.ListColumns(2).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
End With
With ws
NoRow = i
.Cells(NoRow, 5) = arr(i)
.Cells(NoRow, 6).PasteSpecial Paste:=xlPasteValues, Transpose:=True
On Error Resume Next
.ShowAllData
On Error GoTo 0
End With
Next i
With Application
.ScreenUpdating = True
End With
End Sub
Output

Answer 2

In my hasty look at your code it looks like only the Range(...).PasteSpecial line differs between the different cases. You could eliminate the Select Case structure and instead create an array that holds the columns for the PasteSpecial: cols = {"AH", "AU", "BH", "BU", "CH", "CU"}. Then you could select the column by TheCol = cols(year-2011).
Another way: since the columns are regularly spaced (13 apart) you could go by column number: col_num = 13*(year-2011) + 21. Then use something like Range.Cells(x, col_num).
Hope that helps