VBA to delete columns from a given list

[Prince27]

Hello Experts,

I'm looking for a VBA to delete columns based on header name.

There are 2 tabs(sheets) "Main Data" and "Columns" respectively.

Columns tab has the list of column names which I need to use for reporting purpose. "Main Data" tab is a dump or raw data which has huge data set. Attached is the image for your reference.

Here i'm looking for VB code to delete columns which are available as a list Columns tab and delete the rest of the columns.

I want the VB code to be dynamic, so that End user can add or delete or modify the list in Columns tab.

 

[Snakehips]

@Prince27
Give this a try.

Sub DeleteColumns()

Application.ScreenUpdating = False
Set MatchRng = Sheets("Columns").Range("A:A")
With Sheets("Main Data")
 
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    For C = LastCol To 1 Step -1
   
        If Not IsNumeric(Application.Match(.Cells(1, C).Value, MatchRng, 0)) Then .Columns(C).EntireColumn.Delete
        
    Next
End With
Application.ScreenUpdating = True
End Sub

Hope that helps.

 

[nardagus]

Hi,

Maybe this will help:

Sub DeleteColumns()
Dim LastColumn As Integer 'verify range to check in Columns sheet against "Main Data" sheet
Dim j As Integer 'for loop

'find last column to check
With Sheets("Main Data")
    LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With

'loop through columns and check if they exist in Columns sheet. If not, delete them
For j = 1 To LastColumn
    With Sheets("Columns").Range("A:A")
            Set c = .Find(What:=Sheets("Main Data").Cells(1, j).Value)
    End With
        If c Is Nothing Then
            Sheets("Main Data").Cells(1, j).EntireColumn.Delete
        End If
Next j

End Sub

 

[offthelip]

try this:

With Worksheets("Columns")
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
colarr = .Range(.Cells(1, 1), .Cells(lastrow, 1))
End With
With Worksheets("Main Data")
lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
 heads = .Range(.Cells(1, 1), .Cells(1, lastcol))
  For i = lastcol To 1 Step -1
    fnd = False
    For j = 1 To lastrow
     If heads(1, i) = colarr(j, 1) Then
      fnd = True
     Exit For
    End If
   Next j
   If Not (fnd) Then
        .Columns(i).Delete Shift:=xlShiftToLeft
   End If
  Next i
End With
End Sub

 

[Prince27]

Thank you for the code, its working as I expected. But one challenge if "Columns" tab and "Main Data" are in different workbooks, the code is not working. Can you please help me on this

 

[offthelip]

try this code: obviously you must update the workbook names to tie up your workbook names:

Windows("Columnsworkbookname").Activate
With Worksheets("Columns")
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
colarr = .Range(.Cells(1, 1), .Cells(lastrow, 1))
End With

Windows("maindataworkbookname").Activate
With Worksheets("Main Data")
lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
 heads = .Range(.Cells(1, 1), .Cells(1, lastcol))
  For i = lastcol To 1 Step -1
    fnd = False
    For j = 1 To lastrow
     If heads(1, i) = colarr(j, 1) Then
      fnd = True
     Exit For
    End If
   Next j
   If Not (fnd) Then
        .Columns(i).Delete Shift:=xlShiftToLeft
   End If
  Next i
End With

 

[Prince27]

Thank you it does helped.

One small change or modification to the code am looking for.

In the columns tab i have a list of columns right, when i run the macro to delete the columns which are not listed here, i want the column name (cell value ) in the list to be highlighted in red if that particularly column is not available in Main Data tab

Thank you in advance

 

[offthelip]

That "small change" is not a small change, and if i had known that was a requirement at the start I might not have coded it the way I did. Also using color as way of indicating a logical condition is a poor design, it is much easier in VBA to set a column of values to true and false than it is to set the cells to different colors. You can get a similar effect by using conditional formatting.

 

[Prince27]

My Bad for not giving requirement earlier. Could you be able to help me with code to meet both the requirements i'm looking for. Thank you for your help.

 

[offthelip]

Try this code:

Sub test()
Dim fnda() As Variant
With Worksheets("Columns")
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
colarr = .Range(.Cells(1, 1), .Cells(lastrow, 1))
End With
ReDim fnda(1 To lastrow)
For k = 1 To lastrow
 fnda(k) = False
Next k
With Worksheets("Main Data")
lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
 heads = .Range(.Cells(1, 1), .Cells(1, lastcol))
  For i = lastcol To 1 Step -1
    fnd = False
    For j = 1 To lastrow
     If heads(1, i) = colarr(j, 1) Then
      fnda(j) = True
      fnd = True
      
     Exit For
    End If
   Next j
   If Not (fnd) Then
        .Columns(i).Delete Shift:=xlShiftToLeft
   End If
  Next i
End With
With Worksheets("Columns")
 For i = 1 To lastrow
  If Not (fnda(i)) Then
     With Range(.Cells(i, 1), .Cells(i, 1)).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
  End If
Next i
End With
End Sub