VBA Delete Columns with less than 5 values

[baz9d93]

I have found lots of posts to delete empty columns - however I need to delete columns with less than 5 values inside it.

There are 1000 columns I need only the ones that have more than 5 values inside them.

If it can be done via VBA better

just to clairfy i mean five values for example not number 5

Thank You

have tried using power query but taking like 9 hours still not finished

 

[Joe4]

Is there some sort of column header in row 1 that we can use to quickly and easily find the last possible column?

 

[Joe4]

If the answer to my previous question is "Yes", then try something like this:

Sub MyDeleteColumns()

    Dim lc As Long
    Dim c As Long
    Dim ad As String
    Dim cl As String
    Dim rng As Range
    
    Application.ScreenUpdating = False
    
'   Find last column in row 1 with data
    lc = Cells(1, Columns.Count).End(xlToLeft).Column
    
'   Loop through all columns and delete ones with less than 5 values
    For c = lc To 1 Step -1
'       Get cell address
        ad = Cells(1, c).Address(0, 0)
'       Get column letter
        cl = Left(ad, Len(ad) - 1)
'       Build column range
        Set rng = Columns(cl)
'       See if count of entries in is less than 5
        If Application.WorksheetFunction.CountA(rng) < 5 Then
'           Delete column
            rng.Delete
        End If
    Next c

    Application.ScreenUpdating = True

End Sub

Note that I could have made the code a bit shorter, but I broke out each step to more clearly show what it is doing.

 

[baz9d93]

Thank you for your reply - ALL columns have headers sorry I should have mentioned this please check mockup
after running it can post result to sheet 2 with all columns with 5 or more - either way is fine as long as the ones with less than are gone

would the code you have kindly posted here still work

 

[Joe4]

It does it right in place.
Because it is including the header in the count, you probably want to change this line:

If Application.WorksheetFunction.CountA(rng) < 5

to this:

If Application.WorksheetFunction.CountA(rng) <= 5

If you don't want it to happen in place, and want it to happen on another sheet, simply add steps to the top of the code to copy over the entire first sheet to the second, and then run the code on the second sheet.

 

[kevin9999]

Another option:

Option Explicit
Sub baz9d93()
    Application.ScreenUpdating = False
    Dim Ws1 As Worksheet, Ws2 As Worksheet
    Set Ws1 = Worksheets("Sheet1")
    Set Ws2 = Worksheets("Sheet2")
    
    Dim LRow As Long, LCol As Long
    LRow = Ws1.Cells.Find("*", , xlFormulas, , 1, 2).Row
    LCol = Ws1.Cells.Find("*", , xlFormulas, , 2, 2).Column
    
    Dim ArrIn, ArrOut
    ArrIn = Ws1.Range(Ws1.Cells(1, 1), Ws1.Cells(LRow, LCol))
    ReDim ArrOut(1 To 1, 1 To LCol)
    
    Dim i As Long
    For i = 1 To LCol
        If WorksheetFunction.CountA(Ws1.Range(Ws1.Cells(1, i), Ws1.Cells(LRow, i))) < 6 Then ArrOut(1, i) = 1
    Next i
    
    Ws2.UsedRange.ClearContents
    Ws1.Range(Ws1.Cells(1, 1), Ws1.Cells(LRow, LCol)).Copy Ws2.Cells(2, 1)
    Ws2.Range("A1").Resize(1, LCol).Value = ArrOut
    
    i = WorksheetFunction.Sum(Ws2.Range("1:1"))
    If i > 0 Then
        With Ws2
            .UsedRange.Sort Key1:=Ws2.Range("A1"), Orientation:=xlLeftToRight
            .Range("A1").Resize(, i).EntireColumn.Delete
            .Rows("1:1").Delete xlShiftUp
        End With
    End If
    
    Application.ScreenUpdating = True
End Sub

 

[baz9d93]

Big Thank you to both of you for kindly posting your replies so quickly after I made the post.

Note for anyone in future who wants to use this - please check your excel sheet first and you will need to remove trailing and leading spaces - otherwise nothing happens -
not sure why but I worked it out after few attempts as I have run into similar issue in past - I thought I would try it - then both methods worked.

Also important if your excel sheet was generated after running a power query as I found this too creates the problem. Eventhough on the actual sheet you may not see any leading or trailing spaces.

Both methods work

I did notice kevin9999 executed in few minutes like very very fast - mindblowing speed as to everything else I have been use to when running any kind of VBA on this data sheet with 1000 columns and 50000 rows - If he can be kind enough to explain why this is then it would be great for learning as all VBA I have run so far for any kind of task takes min 50 mins - 4 hours on this sheet.

Given both likes but not able to mark both as solution

 

[kevin9999]

Big Thank you to both of you for kindly posting your replies so quickly after I made the post.

Note for anyone in future who wants to use this - please check your excel sheet first and you will need to remove trailing and leading spaces - otherwise nothing happens -
not sure why but I worked it out after few attempts as I have run into similar issue in past - I thought I would try it - then both methods worked.

Also important if your excel sheet was generated after running a power query as I found this too creates the problem. Eventhough on the actual sheet you may not see any leading or trailing spaces.

Both methods work

I did notice kevin9999 executed in few minutes like very very fast - mindblowing speed as to everything else I have been use to when running any kind of VBA on this data sheet with 1000 columns and 50000 rows - If he can be kind enough to explain why this is then it would be great for learning as all VBA I have run so far for any kind of task takes min 50 mins - 4 hours on this sheet.

Given both likes but not able to mark both as solution

Glad we could help & thanks for the feedback
If both methods worked for you, I would mark @Joe4 's solution as the answer because he provided it first. The reason(s) my code works fast is because the data is loaded into a array to test rather than accessing the worksheet directly (to see whether each column contains 5 values) therefore the processing happens in RAM; the Sort (left to right) to group all columns for deletion is a built-in Excel function that works very quickly; and grouping columns (or rows for that matter) as a contiguous block is the fastest way to delete them en masse.

 

[Joe4]

If both methods worked for you, I would mark @Joe4 's solution as the answer because he provided it first.

Kevin,
That is very kind of you to say, but if he likes your code better because it is faster (which is always a good reason to like it!), I have no problems with him marking your post as the solution.
So feel free to mark either one as the solution; whichever one suited your needs best.