remove columns whose headers don't match sheet name

[Kaps_mr2]

Hello,

I am trying to loop through all the sheets in a workbook and delete any columns where the value in row 1 is not equal to the sheet name. The data always starts in column 16 and extends for a variable number of columns to the right. My code is below:-

Public Sub remove_extra_categories()
Dim sh As Long
Dim c As Long
Dim category_data_range As Range
Dim sheet_name As String
Dim last_column_of_data As String
Dim current_column_header As String

For sh = 1 To no_of_categories
    sheet_name = output_workbook.Sheets(sh).Name
    last_column_of_data = output_workbook.Sheets(sh).Cells(1, Columns.Count).End(xlToLeft).Column - 13
    'MsgBox sheet_name & " " & last_column_of_data
    
    For c = last_column_of_data To 16 Step -1
        current_column_header = output_workbook.Sheets(sh).Range("o1").Offset(0, c).Value
        
        If current_column_header <> sheet_name Then
        output_workbook.Sheets(sh).Columns(c).Delete
        End If
        
    Next c
    
Next sh

 

[Skyybot]

Try this on a copy of your Workbook as unexpected results my occur. I'm not sure if this will work on your version of Excel as your Platform and Version are not specified in your Profile.

Public Sub remXcats()
Dim wb As Workbook, sht As Worksheet, chkRng As Range, cellx As Range, cols As Long
Dim str As String, c As Long, i As Long
Set wb = ThisWorkbook: Set sht = ActiveSheet: str = sht.Name
c = sht.UsedRange.Columns.Count
cols = sht.UsedRange.Columns.Column
Set chkRng = sht.Range(sht.Cells(1, 16), sht.Cells(1, (cols + c) - 1))
For i = (cols + c) - 1 To cols Step -1
    If Not sht.Cells(1, i).Value = sht.Name Then
        sht.Columns(i).Delete
    End If
Next
End Sub

 

[Skyybot]

Try this on a copy of your Workbook as unexpected results my occur. I'm not sure if this will work on your version of Excel as your Platform and Version are not specified in your Profile.

Public Sub remXcats()
Dim wb As Workbook, sht As Worksheet, chkRng As Range, cellx As Range, cols As Long
Dim str As String, c As Long, i As Long
Set wb = ThisWorkbook: Set sht = ActiveSheet: str = sht.Name
c = sht.UsedRange.Columns.Count
cols = sht.UsedRange.Columns.Column
Set chkRng = sht.Range(sht.Cells(1, 16), sht.Cells(1, (cols + c) - 1))
For i = (cols + c) - 1 To cols Step -1
    If Not sht.Cells(1, i).Value = sht.Name Then
        sht.Columns(i).Delete
    End If
Next
End Sub

Sorry, this will not work. I did not carefully read your request. It only works for Activesheet. I will edit to loop through all Sheets. Stand by.

 

[Skyybot]

This should do it.

Public Sub remXcats()
Application.ScreenUpdating = False
Dim wb As Workbook, sht As Worksheet, chkRng As Range, cellx As Range, cols As Long
Dim str As String, c As Long, i As Long, shtCount As Long, mySht As Worksheet
Set wb = ThisWorkbook
shtCount = wb.Worksheets.Count
For Each mySht In wb.Worksheets
    Set sht = Worksheets(mySht.Index): str = sht.Name
    c = sht.UsedRange.Columns.Count
    cols = sht.UsedRange.Columns.Column
    Set chkRng = sht.Range(sht.Cells(1, 16), sht.Cells(1, (cols + c) - 1))
    For i = (cols + c) - 1 To cols Step -1
        If Not sht.Cells(1, i).Value = sht.Name Then
            sht.Columns(i).Delete
        End If
    Next i
Next mySht
Application.ScreenUpdating = True
End Sub

 

[Kaps_mr2]

Public Sub remXcats() Application.ScreenUpdating = False Dim wb As Workbook, sht As Worksheet, chkRng As Range, cellx As Range, cols As Long Dim str As String, c As Long, i As Long, shtCount As Long, mySht As Worksheet Set wb = ThisWorkbook shtCount = wb.Worksheets.Count For Each mySht In wb.Worksheets Set sht = Worksheets(mySht.Index): str = sht.Name c = sht.UsedRange.Columns.Count cols = sht.UsedRange.Columns.Column Set chkRng = sht.Range(sht.Cells(1, 16), sht.Cells(1, (cols + c) - 1)) For i = (cols + c) - 1 To cols Step -1 If Not sht.Cells(1, i).Value = sht.Name Then sht.Columns(i).Delete End If Next i Next mySht Application.ScreenUpdating = True End Sub

Thanks. I have set wb to output_workbook but it seems to delete information from the wrong workbook. I can't see why.

 

[Skyybot]

I didn't account for more than one Workbook being open. What is the Filename of the Workbook that you want the code to run on? You will have to set wb as follows:

Set wb = "MyWorkbook.xlsx"    <-------------Change to suit the name of your Workbook

 

[Kaps_mr2]

Thanks. I have set wb to output_workbook but it seems to delete information from the wrong workbook. I can't see why.

the user selects the file via a dialogue and it is set to ouput_workbook. thank you.

 

[Skyybot]

the user selects the file via a dialogue and it is set to ouput_workbook. thank you.

Is the Workbook open at the time of User select?

 

[Skyybot]

the user selects the file via a dialogue and it is set to ouput_workbook. thank you.

Where is the code that runs the User file select dialog?

 

[Kaps_mr2]

Is the Workbook open at the time of User select?

no.