VBA - Copy columns based on match and paste into new sheets

[AsdFgh123]

Hi

I'm relatively new to vba here so hopefully someone can help as I've been searching for answers to this for two days now. I have a spreadsheet with data which contains approx 1000 variables as well as respondent info at the end.
Each variable is in a separate column as can be seen below.

	A	B	C	D	E	F	G	H	I
1	Age1	Age2a	Age2b	Age3	MarStat1	MarStat2	Travel1	Travel2a	Travel2b
2	Yes	Agree	No	2	Yes	No	Yes	Agree	No
3	No	Yes	No	3	No	Yes	No	Agree	No
4	Yes	Agree	Yes	8	No	No	No	Disagree	Yes

<tbody>
</tbody>

I'm attempting to write vba which will cycle through each column header and compare it to the beginning.
When it reaches a new variable topic (i.e. MarStat) it will copy and paste the data on the first variable topic (i.e. Age) into a sheet and name the sheet for that topic.
It will then carry on where it left off.


I've been attempting to adapt the code as given here.
MS Excel 2003: Test each value in column A and copy matching values into new sheets


My code as it is, is below. Unfortunately a system like this works only if I transpose the data into rows rather than columns which isn't ideal.
Also, it only works if all the column headers are the same (e.g. Age, Age, Age, MarStat, MarStat, etc).
I need it to take all of the variables that begin Age, and copy them in a sheet Called Age, regardless of the mumber or text after that number.
As you can see in the example, each topic has a different length name too, and there are a different number of columns for each topic.


'2. Copy columns into new sheet


Sub CopyData()


Dim LMainSheet As String
Dim LCol As Integer
Dim LContinue As Boolean
Dim LMasterCell As String
Dim LTestCell As String

'Retrieve name of sheet that contains the data
LMainSheet = ActiveSheet.Name

'Initialize variables
LContinue = True
LCol = 2

'Start comparing with cell A1
LMasterCell = "A1"

'Loop through all column A values until a blank cell is found
While LContinue = True

LCol = LCol + 1
LTestCell = "A" & CStr(LCol)

'Found a blank cell, do not continue
If Len(Range(LTestCell).Value) = 0 Then
LContinue = False
End If

'Found occurrence that did not match, copy data to new sheet
If Range(LMasterCell).Value <> Range(LTestCell).Value Then

'Copy data from columns A - N
Sheets(LMainSheet).Select
Range(LMasterCell & ":N" & CStr(LCol - 1)).Select
Selection.Copy

'Add new sheet and paste headings into new sheet
Sheets.Add.Name = Range(LMasterCell).Value
ActiveSheet.Paste
Range("A1").Select

'Go back to Main sheet and continue where left off
Sheets(LMainSheet).Select
LMasterCell = "A" & CStr(LCol)

End If

Wend

Range("A1").Select
Application.CutCopyMode = False


MsgBox "Copy has completed."

End Sub


Thanks in advance!