Ok, here you go. It's a little bit more code. I've tried to add details to the code, you'll see this as GREEN text when you insert it into your module.
Sub Data()
Dim LastRow As Integer
Dim WorkingYear As String
Dim ws As Variant
'Name first sheet
Sheets(1).Name = "Data"
'Find last row, this indicates how much data we have to process
LastRow = Range("D1048576").End(xlUp).Row
'FOR Loop, from 1 to Last Row
For x = 1 To LastRow
'Check D1 / D2 / D3 etc for EFProdPerCap, if found then continue, otherwise go to next row
If Range("D" & x).Value = "EFProdPerCap" Then
'Set variable for Year
WorkingYear = Range("C" & x).Value
'Check if Year Worksheet has already been created or not
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = WorkingYear Then
ws.Select
GoTo continue: '<---- I'm usually against GoTo, but this is probably the easiest way for now
End If
Next ws
'Add Sheet and give name (Year)
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = WorkingYear
'Give new sheet column headers
Range("A1").Value = "COUNTRY"
Range("B1").Value = "CODE"
Range("C1").Value = "RECORD"
Range("D1").Value = "TOTAL"
continue:
'Copy data from main sheet and place it into newly created sheet - (Part 1)
Sheets(1).Range("A" & x, "B" & x).Copy
'Find Next avaliable row and paste data - (Part 1)
Range("A1048576").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
'Copy data from main sheet and place it into newly created sheet - (Part 1)
Sheets(1).Range("D" & x, "E" & x).Copy
'Find Next avaliable row and paste data - (Part 1)
Range("C1048576").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
'This should grab all the EFConsPerCap information. Just using an offset to grab this information - (Part 2)
Sheets(1).Range("A" & x, "B" & x).Offset(6, 0).Copy
Range("A1048576").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
'This should grab all the EFConsPerCap information. Just using an offset to grab this information - (Part 2)
Sheets(1).Range("D" & x, "E" & x).Offset(6, 0).Copy
Range("C1048576").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
'Autofit columns
Cells.EntireColumn.AutoFit
Range("A1").Select
Sheets(1).Select
End If
Next x
End Sub
Again, delete Sheets 2 and 3... And then run the code.
You'll be left with Sheets looking like this:
And the data in each sheet will look like this.
Again, I hope this is what you want.