Selecting columns based off header

[vpupko]

I have got a very large dataset on which I need to perform some data analysis. There are roughly 100 variables but there are multiple iterations so in the end it is closer to 15,000 variables. I need a way to select just the variables with the same header in a new worksheet as that will make it much easier as it is currently unordered.

As an example:

V1	V2	V3	V2	V3	V1	V2	V3	..
4	6	8	9	7	7	8	48	..
5	4	6	5	6	5	1	6	..
6	8	4	12	3	6	5	12	..
..	..	..	..	..	..	..	..	..

<tbody>
</tbody>

And the output I'm looking for in a new worksheet:

If I want to see every V3 Variable..

V3	V3	V3
8	7	48
6	6	6
4	3	12
..	..	..

<tbody>
</tbody>

I have written out an Excel Formula that sort of does this, but my computer does not have the memory to execute (The dataset has 7,500,00 cells worth of data) so maybe a macro or a more optimised formula would work.

Just thinking off the top of my head, if there is a way to just split it up once so every variable is automatically split and outputted like this in one go rather than redoing it over and over again that would be brilliant

Cheers

 

[sheetspread]

it is closer to 15,000 variables

The dataset has 7,500,00 cells worth of data)

Does that mean 500 rows? Why not transpose, filter, delete, and transpose again?

 

[vpupko]

Does that mean 500 rows? Why not transpose, filter, delete, and transpose again?

Yeah I was just thinking about this, however this sounds like it will take a long time as have to repeat the process for every unique variable. Was hoping there was a way to automate/optimize the process.

 

[sheetspread]

Then just sort by column

 

[skywriter]

You can try this, just change the sheet names.

Sheet1 in the code is where the data would be sheet2 is the sheet where the data is going.

This code assumes you have no blank cells in your columns of data.

Sub vpupko()
Dim lc As Long
Dim c As Long
Dim r As Range, r2 As Range
Dim v As String, strAddress As String
v = InputBox("Enter the variable.")
c = 1
    With Worksheets("Sheet1").Rows(1)
    lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Set r = .Find(v, After:=.Cells(1, lc), LookAt:=xlWhole)
            If r Is Nothing Then
                MsgBox "No matches found for " & v & "."
                Exit Sub
            Else
                strAddress = r.Address
                Application.ScreenUpdating = False
            End If
            Do
                Set r2 = .Range(r, r.End(xlDown))
                Worksheets("Sheet2").Cells(1, c).Resize(r2.Rows.Count, 1).Value = r2.Value
                c = c + 1
                Set r = .FindNext(r)
            Loop While Not r Is Nothing And r.Address <> strAddress
    End With
    Application.ScreenUpdating = True
End Sub

 

[vpupko]

Sub vpupko()
Dim lc As Long
Dim c As Long
Dim r As Range, r2 As Range
Dim v As String, strAddress As String
v = InputBox("Enter the variable.")
c = 1
    With Worksheets("Sheet1").Rows(1)
    lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Set r = .Find(v, After:=.Cells(1, lc), LookAt:=xlWhole)
            If r Is Nothing Then
                MsgBox "No matches found for " & v & "."
                Exit Sub
            Else
                strAddress = r.Address
                Application.ScreenUpdating = False
            End If
            Do
                Set r2 = .Range(r, r.End(xlDown))
                Worksheets("Sheet2").Cells(1, c).Resize(r2.Rows.Count, 1).Value = r2.Value
                c = c + 1
                Set r = .FindNext(r)
            Loop While Not r Is Nothing And r.Address <> strAddress
    End With
    Application.ScreenUpdating = True
End Sub

This is great. Is it possible to automate this process so it goes along the first row and for every unique header it creates a new worksheet with all the corresponding duplicate headers as well?

 

[sheetspread]

With your sample in A1:H4 of a worksheet called Master I ran:

Sub sortandsplit()
Dim wRange As Range, sr As Range, lr%, lc%, i%, x%, gn As String, m As Worksheet
Set m = Sheets("Master")
x = 0
lr = m.Cells(Rows.Count, 1).End(xlUp).Row
lc = m.Cells(1, Columns.Count).End(xlToLeft).Column
Set wRange = m.Range("A1").Resize(lr, lc)
Set sr = m.Range("A1").Resize(, lc)
wRange.Sort Key1:=sr, Order1:=xlAscending, Header:=xlYes
For i = 2 To lc
If m.Cells(1, i) <> m.Cells(1, i + 1) Then
gn = m.Cells(1, i).Value
Sheets.Add.Name = gn
Sheets(gn).Cells(1, 1).Resize(lr, i - x).Value = m.Cells(1, x + 1).Resize(lr, i - x).Value
x = i
Else
End If
Next
End Sub

and it worked

 

[vpupko]

It works for me with a sample worksheet as well thank you very much.
I added:

Sheets(gn).Delete

above the Add.Name line so it doesn't error out if you re-run it in the same workbook.