Macro to populate sheets

[lanefra]

Hello, I'm fairly new at macros and I need some help!

I have a sheet that's made of column heads and the data below it. I need to create a new sheet that is named for the column head, and populate those sheets with the data located under the column name. However, in the column there are empty slots which need to be filtered out. In addition, I need to keep the MP column and have that added to each sheet.
I have tried recording macros but it is not general enough so that if the column heads have different names, it will still work.
I realise this is a complicated project and I am welcome to any suggested solutions.
Thank you!

 

[breynolds0431]

Hi. Try adding the below to a normal module. This will loop through row 1 and create sheets named with each column header. The main data will be copied to this new sheet in whole. In the new sheet, each column will be deleted if it doesn't match the new sheet's name. Likewise, each row with a blank will be deleted.

Option Explicit

Sub FillSheets()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Data") '<- update to actual sheet name
Dim wsRow As Long: wsRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row 'finds lrow of ws in column 1
Dim wsCol As Integer: wsCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column 'finds last column of ws in row 1
Dim c As Range 'variable for loop
Dim nWS As Worksheet 'variable for new sheet

For Each c In ws.Range(ws.Cells(1, 3), ws.Cells(1, wsCol)).Cells 'loops through row 1 column headers
    If c.Value <> "" Then
        ws.UsedRange.Copy 'copies ws
        Sheets.Add After:=Sheets(Sheets.Count) 'adds new sheet at end of workbook
        ActiveSheet.Name = c.Value 'new sheet is named after column header
        Set nWS = ActiveSheet 'variable of new sheet is assigned
        nWS.Range("A1").PasteSpecial 'data from ws is pasted to new sheet

        Dim lngLastCol As Long, lngIdx As Long 'variables for new sheet updating
        
        With nWS
            lngLastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 'last column of new sheet
            
            'Loop from the right to left, deleting columns not matching New Sheet's name
            For lngIdx = lngLastCol To 3 Step -1
                If .Cells(1, lngIdx) <> nWS.Name Then 'if the column header is equal to tab's name, delete column
                    .Columns(lngIdx).Delete
                End If
            Next lngIdx
            .Columns(3).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'Delete all blank rows
        End With
    End If
Next c

End Sub

 

[lanefra]

Thanks for your reply! However, when I use this macro I'm getting a subscript out of range error, would you know what is causing that?

Thanks again!

 

[breynolds0431]

Can you screenshot where the error is? The affected line should be highlighted in vba.

 

[lanefra]

Sure!

 

[breynolds0431]

Sure!

I used a sheet called Data to test. You would want to replace Data with the sheet name of where your data resides (i.e.; the tab to split to new tabs).

 

[lanefra]

It works perfectly!! Thank you so much