Roger's Access Library Homepage
Forum Home Forum Home > Other Download Libraries > MS Access MVP Libraries > Long, Crystal
  New Posts New Posts RSS Feed - Delete Empty Excel columns (after label rows)
  FAQ FAQ  Forum Search   Events   Register Register  Login Login


Please consider donating $1 per sample downloaded, (find out why here)

Delete Empty Excel columns (after label rows)

 Post Reply Post Reply
Author
Message
 Rating: Topic Rating: 2 Votes, Average 3.00  Topic Search Topic Search  Topic Options Topic Options
Crystal Long View Drop Down
Microsoft MVP
Microsoft MVP


Joined: 21 May 2012
Location: Colorado
Status: Offline
Points: 35
Post Options Post Options   Thanks (0) Thanks(0)   Quote Crystal Long Quote  Post ReplyReply Direct Link To This Post Topic: Delete Empty Excel columns (after label rows)
    Posted: 05 May 2016 at 9:41am
Delete Columns in Excel that are Empty

Use this code to delete columns that are completely empty by sending a parameter of one (1) for the first data row.  The default is currently to assume there is a row of labels to skip in determining if there is data in the column.

This is also perfect to run from Access after writing the results of a query where you only want to see columns with information.


Sub runDeleteColumnsNoData()
'crystal
   'object variable does not need to be defined when using from Excel
   'done this way to show how it would be done from Access
  
   Dim oSht As Object  'Excel.Worksheet
   Set oSht = ActiveSheet
  
   Call DeleteColumnsNoData(oSht)
   Set oSht = Nothing
End Sub

Function DeleteColumnsNoData(oSht As Excel.Worksheet _
   , Optional pnRow1 As Long = 2 _
   ) As Long
'strive4peace 160505
'delete columns that are empty except for possible data in label rows
'
   'PARAMETERS
   '  oSht = worksheet object
   '  pnRow1 = first row to check. Set to 1 to delete completely empty columns
   '
   'RETURNS
   '  number of columns deleted
  
   On Error GoTo Proc_Err

   Dim nRow2 As Long _
      , nCol1 As Long _
      , nCol2 As Long _
      , nCol As Long _
      , nNextRowData As Long _
      , nCountColsDeleted As Long _
      , sMsg As String
      
   DeleteColumnsNoData = 0
   '------------------------------------
   nCol1 = 1 'first column to check
   nCountColsDeleted = 0
  
  With oSht
      nRow2 = .UsedRange.Rows.Count  '.Cells(.Rows.Count, 1).End(xlUp).Row 'xlUp=-4162
      nCol2 = .UsedRange.Columns.Count '.Cells(1, .Columns.Count).End(xlToLeft).Column 'xlToLeft=-4159
   End With
  
   '---------------------------- if automating, comment this
   sMsg = "DELETE All Columns from " _
      & GetColumnLetter(nCol1) & " to " & GetColumnLetter(nCol2) _
      & " (" & nCol1 & " to " & nCol2 & ") " _
      & " with no data in cells " _
      & vbCrLf & "from Row " & pnRow1 & " to Row " & nRow2 & "?" _
      & vbCrLf & vbCrLf & "If you want to be able to 'undo' then " _
      & "save your workbook first"
      
   If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "Yes to DELETE COLUMNS?") <> vbYes Then
      GoTo Proc_Exit
   End If
   '----------------------------
  
   With oSht
       For nCol = nCol2 To nCol1 Step -1
          If pnRow1 > 1 Or (pnRow1 = 1 And Not .Cells(pnRow1, nCol) <> "") Then
             nNextRowData = .Cells(pnRow1, nCol).End(xlDown).Row
             If nNextRowData > nRow2 Then
               .Columns(nCol).Delete
               nCountColsDeleted = nCountColsDeleted + 1
             End If
          End If
       Next nCol
    End With
  
   DeleteColumnsNoData = nCountColsDeleted
   '---------------------------- if automating, comment this
   sMsg = nCountColsDeleted & " Columns Deleted"
   MsgBox sMsg, , "Done"
   '----------------------------
  
Proc_Exit:
   On Error Resume Next
   Set oSht = Nothing
   Exit Function
 
Proc_Err:
   MsgBox Err.Description, , _
        "ERROR " & Err.Number _
        & "   DeleteColumnsNoData"

   Resume Proc_Exit
   Resume  
End Function

Function GetColumnLetter(pCol As Long) As String
'130116 strive4peace
   If pCol <= 26 Then
      GetColumnLetter = Chr(pCol + 64)
   Else
      GetColumnLetter = Chr(Int((pCol - 1) / 26) + 64) _
         & Chr(((pCol - 1) Mod 26) + 65)
   End If
End Function


Warm Regards,
Crystal
Microsoft MVP
Remote Training & Programming
Let's Connect and Build Together

http://www.AccessMVP.com/strive4peace
http://YouTube.com/LearnAccessByCrystal
~have an awesome day ~
Back to Top
Sponsored Links


Back to Top
 Post Reply Post Reply
  Share Topic   

Forum Jump Forum Permissions View Drop Down